Auch die ID des Kontos zurückliefern.
[kivitendo-erp.git] / SL / User.pm
1 #=====================================================================
2 # LX-Office ERP
3 # Copyright (C) 2004
4 # Based on SQL-Ledger Version 2.1.9
5 # Web http://www.lx-office.org
6 #
7 #=====================================================================
8 # SQL-Ledger Accounting
9 # Copyright (C) 2001
10 #
11 #  Author: Dieter Simader
12 #   Email: dsimader@sql-ledger.org
13 #     Web: http://www.sql-ledger.org
14 #
15 #  Contributors:
16 #
17 # This program is free software; you can redistribute it and/or modify
18 # it under the terms of the GNU General Public License as published by
19 # the Free Software Foundation; either version 2 of the License, or
20 # (at your option) any later version.
21 #
22 # This program is distributed in the hope that it will be useful,
23 # but WITHOUT ANY WARRANTY; without even the implied warranty of
24 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
25 # GNU General Public License for more details.
26 # You should have received a copy of the GNU General Public License
27 # along with this program; if not, write to the Free Software
28 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
29 #=====================================================================
30 #
31 # user related functions
32 #
33 #=====================================================================
34
35 package User;
36
37 use IO::File;
38 use Fcntl qw(:seek);
39
40 use SL::DBUpgrade2;
41 use SL::DBUtils;
42 use SL::Iconv;
43 use SL::Inifile;
44
45 sub new {
46   $main::lxdebug->enter_sub();
47
48   my ($type, $memfile, $login) = @_;
49   my $self = {};
50
51   if ($login ne "") {
52     local *MEMBER;
53
54     $login =~ s|.*/||;
55
56     &error("", "$memfile locked!") if (-f "${memfile}.LCK");
57
58     open(MEMBER, "$memfile") or &error("", "$memfile : $!");
59
60     while (<MEMBER>) {
61       if (/^\[$login\]/) {
62         while (<MEMBER>) {
63           last if m/^\[/;
64           next if m/^(#|\s)/;
65
66           # remove comments
67           s/\s#.*//g;
68
69           # remove any trailing whitespace
70           s/^\s*(.*?)\s*$/$1/;
71
72           ($key, $value) = split(/=/, $_, 2);
73
74           if (($key eq "stylesheet") && ($value eq "sql-ledger.css")) {
75             $value = "lx-office-erp.css";
76           }
77
78           $self->{$key} = $value;
79         }
80
81         $self->{login} = $login;
82
83         last;
84       }
85     }
86     close MEMBER;
87   }
88
89   $main::lxdebug->leave_sub();
90   bless $self, $type;
91 }
92
93 sub country_codes {
94   $main::lxdebug->enter_sub();
95
96   local *DIR;
97
98   my %cc       = ();
99   my @language = ();
100
101   # scan the locale directory and read in the LANGUAGE files
102   opendir(DIR, "locale");
103
104   my @dir = grep(!/(^\.\.?$|\..*)/, readdir(DIR));
105
106   foreach my $dir (@dir) {
107     next unless open(FH, "locale/$dir/LANGUAGE");
108     @language = <FH>;
109     close FH;
110
111     $cc{$dir} = "@language";
112   }
113
114   closedir(DIR);
115
116   $main::lxdebug->leave_sub();
117
118   return %cc;
119 }
120
121 sub login {
122   $main::lxdebug->enter_sub();
123
124   my ($self, $form, $userspath) = @_;
125
126   local *FH;
127
128   my $rc = -3;
129
130   if ($self->{login}) {
131
132     if ($self->{password}) {
133       if ($form->{hashed_password}) {
134         $form->{password} = $form->{hashed_password};
135       } else {
136         $form->{password} = crypt($form->{password},
137                                   substr($self->{login}, 0, 2));
138       }
139       if ($self->{password} ne $form->{password}) {
140         $main::lxdebug->leave_sub();
141         return -1;
142       }
143     }
144
145     unless (-e "$userspath/$self->{login}.conf") {
146       $self->create_config();
147     }
148
149     do "$userspath/$self->{login}.conf";
150     $myconfig{dbpasswd} = unpack('u', $myconfig{dbpasswd});
151
152     # check if database is down
153     my $dbh =
154       DBI->connect($myconfig{dbconnect}, $myconfig{dbuser},
155                    $myconfig{dbpasswd})
156       or $self->error(DBI::errstr);
157
158     # we got a connection, check the version
159     my $query = qq|SELECT version FROM defaults|;
160     my $sth   = $dbh->prepare($query);
161     $sth->execute || $form->dberror($query);
162
163     my ($dbversion) = $sth->fetchrow_array;
164     $sth->finish;
165
166     # add login to employee table if it does not exist
167     # no error check for employee table, ignore if it does not exist
168     $query = qq|SELECT id FROM employee WHERE login = ?|;
169     my ($login) = selectrow_query($form, $dbh, $query, $self->{login});
170
171     if (!$login) {
172       $query = qq|INSERT INTO employee (login, name, workphone, role)| .
173                qq|VALUES (?, ?, ?, ?)|;
174       my @values = ($self->{login}, $myconfig{name}, $myconfig{tel}, "user");
175       do_query($form, $dbh, $query, @values);
176     }
177
178     $self->create_schema_info_table($form, $dbh);
179
180     $dbh->disconnect;
181
182     $rc = 0;
183
184     my $controls =
185       parse_dbupdate_controls($form, $myconfig{"dbdriver"});
186
187     map({ $form->{$_} = $myconfig{$_} }
188         qw(dbname dbhost dbport dbdriver dbuser dbpasswd dbconnect));
189
190     if (update_available($myconfig{"dbdriver"}, $dbversion) ||
191         update2_available($form, $controls)) {
192
193       $form->{"stylesheet"} = "lx-office-erp.css";
194       $form->{"title"} = $main::locale->text("Dataset upgrade");
195       $form->header();
196       print($form->parse_html_template("dbupgrade/header"));
197
198       $form->{dbupdate} = "db$myconfig{dbname}";
199       $form->{ $form->{dbupdate} } = 1;
200
201       if ($form->{"show_dbupdate_warning"}) {
202         print($form->parse_html_template("dbupgrade/warning"));
203         exit(0);
204       }
205
206       # update the tables
207       open(FH, ">$userspath/nologin") or die("$!");
208
209       # required for Oracle
210       $form->{dbdefault} = $sid;
211
212       # ignore HUP, QUIT in case the webserver times out
213       $SIG{HUP}  = 'IGNORE';
214       $SIG{QUIT} = 'IGNORE';
215
216       $self->dbupdate($form);
217       $self->dbupdate2($form, $controls);
218
219       close(FH);
220
221       # remove lock file
222       unlink("$userspath/nologin");
223
224       my $menufile =
225         $self->{"menustyle"} eq "v3" ? "menuv3.pl" :
226         $self->{"menustyle"} eq "neu" ? "menunew.pl" :
227         "menu.pl";
228
229       print($form->parse_html_template("dbupgrade/footer",
230                                        { "menufile" => $menufile }));
231
232       $rc = -2;
233
234     }
235   }
236
237   $main::lxdebug->leave_sub();
238
239   return $rc;
240 }
241
242 sub dbconnect_vars {
243   $main::lxdebug->enter_sub();
244
245   my ($form, $db) = @_;
246
247   my %dboptions = (
248         'Pg' => { 'yy-mm-dd'   => 'set DateStyle to \'ISO\'',
249                   'yyyy-mm-dd' => 'set DateStyle to \'ISO\'',
250                   'mm/dd/yy'   => 'set DateStyle to \'SQL, US\'',
251                   'mm-dd-yy'   => 'set DateStyle to \'POSTGRES, US\'',
252                   'dd/mm/yy'   => 'set DateStyle to \'SQL, EUROPEAN\'',
253                   'dd-mm-yy'   => 'set DateStyle to \'POSTGRES, EUROPEAN\'',
254                   'dd.mm.yy'   => 'set DateStyle to \'GERMAN\''
255         },
256         'Oracle' => {
257           'yy-mm-dd'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'YY-MM-DD\'',
258           'yyyy-mm-dd' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'YYYY-MM-DD\'',
259           'mm/dd/yy'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'MM/DD/YY\'',
260           'mm-dd-yy'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'MM-DD-YY\'',
261           'dd/mm/yy'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD/MM/YY\'',
262           'dd-mm-yy'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD-MM-YY\'',
263           'dd.mm.yy'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD.MM.YY\'',
264         });
265
266   $form->{dboptions} = $dboptions{ $form->{dbdriver} }{ $form->{dateformat} };
267
268   if ($form->{dbdriver} eq 'Pg') {
269     $form->{dbconnect} = "dbi:Pg:dbname=$db";
270   }
271
272   if ($form->{dbdriver} eq 'Oracle') {
273     $form->{dbconnect} = "dbi:Oracle:sid=$form->{sid}";
274   }
275
276   if ($form->{dbhost}) {
277     $form->{dbconnect} .= ";host=$form->{dbhost}";
278   }
279   if ($form->{dbport}) {
280     $form->{dbconnect} .= ";port=$form->{dbport}";
281   }
282
283   $main::lxdebug->leave_sub();
284 }
285
286 sub dbdrivers {
287   $main::lxdebug->enter_sub();
288
289   my @drivers = DBI->available_drivers();
290
291   $main::lxdebug->leave_sub();
292
293   return (grep { /(Pg|Oracle)/ } @drivers);
294 }
295
296 sub dbsources {
297   $main::lxdebug->enter_sub();
298
299   my ($self, $form) = @_;
300
301   my @dbsources = ();
302   my ($sth, $query);
303
304   $form->{dbdefault} = $form->{dbuser} unless $form->{dbdefault};
305   $form->{sid} = $form->{dbdefault};
306   &dbconnect_vars($form, $form->{dbdefault});
307
308   my $dbh =
309     DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
310     or $form->dberror;
311
312   if ($form->{dbdriver} eq 'Pg') {
313     $query =
314       qq|SELECT datname FROM pg_database | .
315       qq|WHERE NOT datname IN ('template0', 'template1')|;
316     $sth = $dbh->prepare($query);
317     $sth->execute() || $form->dberror($query);
318
319     while (my ($db) = $sth->fetchrow_array) {
320
321       if ($form->{only_acc_db}) {
322
323         next if ($db =~ /^template/);
324
325         &dbconnect_vars($form, $db);
326         my $dbh =
327           DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
328           or $form->dberror;
329
330         $query =
331           qq|SELECT tablename FROM pg_tables | .
332           qq|WHERE (tablename = 'defaults') AND (tableowner = ?)|;
333         my $sth = $dbh->prepare($query);
334         $sth->execute($form->{dbuser}) ||
335           $form->dberror($query . " ($form->{dbuser})");
336
337         if ($sth->fetchrow_array) {
338           push(@dbsources, $db);
339         }
340         $sth->finish;
341         $dbh->disconnect;
342         next;
343       }
344       push(@dbsources, $db);
345     }
346   }
347
348   if ($form->{dbdriver} eq 'Oracle') {
349     if ($form->{only_acc_db}) {
350       $query =
351         qq|SELECT owner FROM dba_objects | .
352         qq|WHERE object_name = 'DEFAULTS' AND object_type = 'TABLE'|;
353     } else {
354       $query = qq|SELECT username FROM dba_users|;
355     }
356
357     $sth = $dbh->prepare($query);
358     $sth->execute || $form->dberror($query);
359
360     while (my ($db) = $sth->fetchrow_array) {
361       push(@dbsources, $db);
362     }
363   }
364
365   $sth->finish;
366   $dbh->disconnect;
367
368   $main::lxdebug->leave_sub();
369
370   return @dbsources;
371 }
372
373 sub dbcreate {
374   $main::lxdebug->enter_sub();
375
376   my ($self, $form) = @_;
377
378   $form->{sid} = $form->{dbdefault};
379   &dbconnect_vars($form, $form->{dbdefault});
380   my $dbh =
381     DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
382     or $form->dberror;
383   $form->{db} =~ s/\"//g;
384   my %dbcreate = (
385     'Pg'     => qq|CREATE DATABASE "$form->{db}"|,
386     'Oracle' =>
387     qq|CREATE USER "$form->{db}" DEFAULT TABLESPACE USERS | .
388     qq|TEMPORARY TABLESPACE TEMP IDENTIFIED BY "$form->{db}"|
389   );
390
391   my %dboptions = (
392     'Pg' => [],
393   );
394
395   push(@{$dboptions{"Pg"}}, "ENCODING = " . $dbh->quote($form->{"encoding"}))
396     if ($form->{"encoding"});
397   if ($form->{"dbdefault"}) {
398     my $dbdefault = $form->{"dbdefault"};
399     $dbdefault =~ s/[^a-zA-Z0-9_\-]//g;
400     push(@{$dboptions{"Pg"}}, "TEMPLATE = $dbdefault");
401   }
402
403   my $query = $dbcreate{$form->{dbdriver}};
404   $query .= " WITH " . join(" ", @{$dboptions{"Pg"}}) if (@{$dboptions{"Pg"}});
405
406   do_query($form, $dbh, $query);
407
408   if ($form->{dbdriver} eq 'Oracle') {
409     $query = qq|GRANT CONNECT, RESOURCE TO "$form->{db}"|;
410     do_query($form, $dbh, $query);
411   }
412   $dbh->disconnect;
413
414   # setup variables for the new database
415   if ($form->{dbdriver} eq 'Oracle') {
416     $form->{dbuser}   = $form->{db};
417     $form->{dbpasswd} = $form->{db};
418   }
419
420   &dbconnect_vars($form, $form->{db});
421
422   $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
423     or $form->dberror;
424
425   my $db_charset = $Common::db_encoding_to_charset{$form->{encoding}};
426   $db_charset ||= Common::DEFAULT_CHARSET;
427
428   # create the tables
429   $self->process_query($form, $dbh, "sql/lx-office.sql", undef, $db_charset);
430
431   # load chart of accounts
432   $self->process_query($form, $dbh, "sql/$form->{chart}-chart.sql", undef, $db_charset);
433
434   $query = "UPDATE defaults SET coa = ?";
435   do_query($form, $dbh, $query, $form->{chart});
436
437   $dbh->disconnect;
438
439   $main::lxdebug->leave_sub();
440 }
441
442 # Process a Perl script which updates the database.
443 # If the script returns 1 then the update was successful.
444 # Return code "2" means "needs more interaction; remove
445 # users/nologin and exit".
446 # All other return codes are fatal errors.
447 sub process_perl_script {
448   $main::lxdebug->enter_sub();
449
450   my ($self, $form, $dbh, $filename, $version_or_control, $db_charset) = @_;
451
452   my $fh = IO::File->new($filename, "r") or $form->error("$filename : $!\n");
453
454   my $file_charset = Common::DEFAULT_CHARSET;
455
456   if (ref($version_or_control) eq "HASH") {
457     $file_charset = $version_or_control->{charset};
458
459   } else {
460     while (<$fh>) {
461       last if !/^--/;
462       next if !/^--\s*\@charset:\s*(.+)/;
463       $file_charset = $1;
464       last;
465     }
466     $fh->seek(0, SEEK_SET);
467   }
468
469   my $contents = join "", <$fh>;
470   $fh->close();
471
472   $db_charset ||= Common::DEFAULT_CHARSET;
473
474   my $iconv = SL::Iconv::get_converter($file_charset, $db_charset);
475
476   $dbh->begin_work();
477
478   my %dbup_myconfig = ();
479   map({ $dbup_myconfig{$_} = $form->{$_}; }
480       qw(dbname dbuser dbpasswd dbhost dbport dbconnect));
481
482   my $nls_file = $filename;
483   $nls_file =~ s|.*/||;
484   $nls_file =~ s|.pl$||;
485   my $dbup_locale = Locale->new($main::language, $nls_file);
486
487   my $result = eval($contents);
488
489   if (1 != $result) {
490     $dbh->rollback();
491     $dbh->disconnect();
492   }
493
494   if (!defined($result)) {
495     print($form->parse_html_template("dbupgrade/error",
496                                      { "file" => $filename,
497                                        "error" => $@ }));
498     exit(0);
499   } elsif (1 != $result) {
500     unlink("users/nologin") if (2 == $result);
501     exit(0);
502   }
503
504   if (ref($version_or_control) eq "HASH") {
505     $dbh->do("INSERT INTO schema_info (tag, login) VALUES (" .
506              $dbh->quote($version_or_control->{"tag"}) . ", " .
507              $dbh->quote($form->{"login"}) . ")");
508   } elsif ($version_or_control) {
509     $dbh->do("UPDATE defaults SET version = " .
510              $dbh->quote($version_or_control));
511   }
512   $dbh->commit();
513
514   $main::lxdebug->leave_sub();
515 }
516
517 sub process_query {
518   $main::lxdebug->enter_sub();
519
520   my ($self, $form, $dbh, $filename, $version_or_control, $db_charset) = @_;
521
522   my $fh = IO::File->new($filename, "r") or $form->error("$filename : $!\n");
523   my $query = "";
524   my $sth;
525   my @quote_chars;
526
527   my $file_charset = Common::DEFAULT_CHARSET;
528   while (<$fh>) {
529     last if !/^--/;
530     next if !/^--\s*\@charset:\s*(.+)/;
531     $file_charset = $1;
532     last;
533   }
534   $fh->seek(0, SEEK_SET);
535
536   $db_charset ||= Common::DEFAULT_CHARSET;
537
538   $dbh->begin_work();
539
540   while (<$fh>) {
541     $_ = SL::Iconv::convert($file_charset, $db_charset, $_);
542
543     # Remove DOS and Unix style line endings.
544     chomp;
545
546     # remove comments
547     s/--.*$//;
548
549     for (my $i = 0; $i < length($_); $i++) {
550       my $char = substr($_, $i, 1);
551
552       # Are we inside a string?
553       if (@quote_chars) {
554         if ($char eq $quote_chars[-1]) {
555           pop(@quote_chars);
556         }
557         $query .= $char;
558
559       } else {
560         if (($char eq "'") || ($char eq "\"")) {
561           push(@quote_chars, $char);
562
563         } elsif ($char eq ";") {
564
565           # Query is complete. Send it.
566
567           $sth = $dbh->prepare($query);
568           if (!$sth->execute()) {
569             my $errstr = $dbh->errstr;
570             $sth->finish();
571             $dbh->rollback();
572             $form->dberror("The database update/creation did not succeed. " .
573                            "The file ${filename} containing the following " .
574                            "query failed:<br>${query}<br>" .
575                            "The error message was: ${errstr}<br>" .
576                            "All changes in that file have been reverted.");
577           }
578           $sth->finish();
579
580           $char  = "";
581           $query = "";
582         }
583
584         $query .= $char;
585       }
586     }
587   }
588
589   if (ref($version_or_control) eq "HASH") {
590     $dbh->do("INSERT INTO schema_info (tag, login) VALUES (" .
591              $dbh->quote($version_or_control->{"tag"}) . ", " .
592              $dbh->quote($form->{"login"}) . ")");
593   } elsif ($version_or_control) {
594     $dbh->do("UPDATE defaults SET version = " .
595              $dbh->quote($version_or_control));
596   }
597   $dbh->commit();
598
599   $fh->close();
600
601   $main::lxdebug->leave_sub();
602 }
603
604 sub dbdelete {
605   $main::lxdebug->enter_sub();
606
607   my ($self, $form) = @_;
608   $form->{db} =~ s/\"//g;
609   my %dbdelete = ('Pg'     => qq|DROP DATABASE "$form->{db}"|,
610                   'Oracle' => qq|DROP USER "$form->{db}" CASCADE|);
611
612   $form->{sid} = $form->{dbdefault};
613   &dbconnect_vars($form, $form->{dbdefault});
614   my $dbh =
615     DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
616     or $form->dberror;
617   my $query = $dbdelete{$form->{dbdriver}};
618   do_query($form, $dbh, $query);
619
620   $dbh->disconnect;
621
622   $main::lxdebug->leave_sub();
623 }
624
625 sub dbsources_unused {
626   $main::lxdebug->enter_sub();
627
628   my ($self, $form, $memfile) = @_;
629
630   local *FH;
631
632   my @dbexcl    = ();
633   my @dbsources = ();
634
635   $form->error('File locked!') if (-f "${memfile}.LCK");
636
637   # open members file
638   open(FH, "$memfile") or $form->error("$memfile : $!");
639
640   while (<FH>) {
641     if (/^dbname=/) {
642       my ($null, $item) = split(/=/);
643       push @dbexcl, $item;
644     }
645   }
646
647   close FH;
648
649   $form->{only_acc_db} = 1;
650   my @db = &dbsources("", $form);
651
652   push @dbexcl, $form->{dbdefault};
653
654   foreach $item (@db) {
655     unless (grep /$item$/, @dbexcl) {
656       push @dbsources, $item;
657     }
658   }
659
660   $main::lxdebug->leave_sub();
661
662   return @dbsources;
663 }
664
665 sub dbneedsupdate {
666   $main::lxdebug->enter_sub();
667
668   my ($self, $form) = @_;
669
670   my $members  = Inifile->new($main::memberfile);
671   my $controls = parse_dbupdate_controls($form, $form->{dbdriver});
672
673   my ($query, $sth, %dbs_needing_updates);
674
675   foreach my $login (grep /[a-z]/, keys %{ $members }) {
676     my $member = $members->{$login};
677
678     map { $form->{$_} = $member->{$_} } qw(dbname dbuser dbpasswd dbhost dbport);
679     dbconnect_vars($form, $form->{dbname});
680     $main::lxdebug->dump(0, "form", $form);
681     my $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd});
682
683     next unless $dbh;
684
685     my $version;
686
687     $query = qq|SELECT version FROM defaults|;
688     $sth = prepare_query($form, $dbh, $query);
689     if ($sth->execute()) {
690       ($version) = $sth->fetchrow_array();
691     }
692     $sth->finish();
693     $dbh->disconnect();
694
695     next unless $version;
696
697     if (update_available($form->{dbdriver}, $version) || update2_available($form, $controls)) {
698       my $dbinfo = {};
699       map { $dbinfo->{$_} = $member->{$_} } grep /^db/, keys %{ $member };
700       $dbs_needing_updates{$member->{dbhost} . "::" . $member->{dbname}} = $dbinfo;
701     }
702   }
703
704   $main::lxdebug->leave_sub();
705
706   return values %dbs_needing_updates;
707 }
708
709 sub calc_version {
710   $main::lxdebug->enter_sub(2);
711
712   my (@v, $version, $i);
713
714   @v = split(/\./, $_[0]);
715   while (scalar(@v) < 4) {
716     push(@v, 0);
717   }
718   $version = 0;
719   for ($i = 0; $i < 4; $i++) {
720     $version *= 1000;
721     $version += $v[$i];
722   }
723
724   $main::lxdebug->leave_sub(2);
725   return $version;
726 }
727
728 sub cmp_script_version {
729   my ($a_from, $a_to, $b_from, $b_to);
730   my ($i, $res_a, $res_b);
731   my ($my_a, $my_b) = ($a, $b);
732
733   $my_a =~ s/.*-upgrade-//;
734   $my_a =~ s/.sql$//;
735   $my_b =~ s/.*-upgrade-//;
736   $my_b =~ s/.sql$//;
737   ($my_a_from, $my_a_to) = split(/-/, $my_a);
738   ($my_b_from, $my_b_to) = split(/-/, $my_b);
739
740   $res_a = calc_version($my_a_from);
741   $res_b = calc_version($my_b_from);
742
743   if ($res_a == $res_b) {
744     $res_a = calc_version($my_a_to);
745     $res_b = calc_version($my_b_to);
746   }
747
748   return $res_a <=> $res_b;
749 }
750
751 sub update_available {
752   my ($dbdriver, $cur_version) = @_;
753
754   local *SQLDIR;
755
756   opendir SQLDIR, "sql/${dbdriver}-upgrade" || error("", "sql/${dbdriver}-upgrade: $!");
757   my @upgradescripts = grep /${dbdriver}-upgrade-\Q$cur_version\E.*\.(sql|pl)$/, readdir SQLDIR;
758   closedir SQLDIR;
759
760   return ($#upgradescripts > -1);
761 }
762
763 sub create_schema_info_table {
764   $main::lxdebug->enter_sub();
765
766   my ($self, $form, $dbh) = @_;
767
768   my $query = "SELECT tag FROM schema_info LIMIT 1";
769   if (!$dbh->do($query)) {
770     $dbh->rollback();
771     $query =
772       qq|CREATE TABLE schema_info (| .
773       qq|  tag text, | .
774       qq|  login text, | .
775       qq|  itime timestamp DEFAULT now(), | .
776       qq|  PRIMARY KEY (tag))|;
777     $dbh->do($query) || $form->dberror($query);
778   }
779
780   $main::lxdebug->leave_sub();
781 }
782
783 sub dbupdate {
784   $main::lxdebug->enter_sub();
785
786   my ($self, $form) = @_;
787
788   local *SQLDIR;
789
790   $form->{sid} = $form->{dbdefault};
791
792   my @upgradescripts = ();
793   my $query;
794   my $rc = -2;
795
796   if ($form->{dbupdate}) {
797
798     # read update scripts into memory
799     opendir(SQLDIR, "sql/" . $form->{dbdriver} . "-upgrade")
800       or &error("", "sql/" . $form->{dbdriver} . "-upgrade : $!");
801     @upgradescripts =
802       sort(cmp_script_version
803            grep(/$form->{dbdriver}-upgrade-.*?\.(sql|pl)$/,
804                 readdir(SQLDIR)));
805     closedir(SQLDIR);
806   }
807
808   my $db_charset = $main::dbcharset;
809   $db_charset ||= Common::DEFAULT_CHARSET;
810
811   foreach my $db (split(/ /, $form->{dbupdate})) {
812
813     next unless $form->{$db};
814
815     # strip db from dataset
816     $db =~ s/^db//;
817     &dbconnect_vars($form, $db);
818
819     my $dbh =
820       DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
821       or $form->dberror;
822
823     # check version
824     $query = qq|SELECT version FROM defaults|;
825     my ($version) = selectrow_query($form, $dbh, $query);
826
827     next unless $version;
828
829     $version = calc_version($version);
830
831     foreach my $upgradescript (@upgradescripts) {
832       my $a = $upgradescript;
833       $a =~ s/^$form->{dbdriver}-upgrade-|\.(sql|pl)$//g;
834       my $file_type = $1;
835
836       my ($mindb, $maxdb) = split /-/, $a;
837       my $str_maxdb = $maxdb;
838       $mindb = calc_version($mindb);
839       $maxdb = calc_version($maxdb);
840
841       next if ($version >= $maxdb);
842
843       # if there is no upgrade script exit
844       last if ($version < $mindb);
845
846       # apply upgrade
847       $main::lxdebug->message(DEBUG2, "Applying Update $upgradescript");
848       if ($file_type eq "sql") {
849         $self->process_query($form, $dbh, "sql/" . $form->{"dbdriver"} .
850                              "-upgrade/$upgradescript", $str_maxdb, $db_charset);
851       } else {
852         $self->process_perl_script($form, $dbh, "sql/" . $form->{"dbdriver"} .
853                                    "-upgrade/$upgradescript", $str_maxdb, $db_charset);
854       }
855
856       $version = $maxdb;
857
858     }
859
860     $rc = 0;
861     $dbh->disconnect;
862
863   }
864
865   $main::lxdebug->leave_sub();
866
867   return $rc;
868 }
869
870 sub dbupdate2 {
871   $main::lxdebug->enter_sub();
872
873   my ($self, $form, $controls) = @_;
874
875   $form->{sid} = $form->{dbdefault};
876
877   my @upgradescripts = ();
878   my ($query, $sth, $tag);
879   my $rc = -2;
880
881   @upgradescripts = sort_dbupdate_controls($controls);
882
883   my $db_charset = $main::dbcharset;
884   $db_charset ||= Common::DEFAULT_CHARSET;
885
886   foreach my $db (split / /, $form->{dbupdate}) {
887
888     next unless $form->{$db};
889
890     # strip db from dataset
891     $db =~ s/^db//;
892     &dbconnect_vars($form, $db);
893
894     my $dbh =
895       DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
896       or $form->dberror;
897
898     map({ $_->{"applied"} = 0; } @upgradescripts);
899
900     $self->create_schema_info_table($form, $dbh);
901
902     $query = qq|SELECT tag FROM schema_info|;
903     $sth = $dbh->prepare($query);
904     $sth->execute() || $form->dberror($query);
905     while (($tag) = $sth->fetchrow_array()) {
906       $controls->{$tag}->{"applied"} = 1 if (defined($controls->{$tag}));
907     }
908     $sth->finish();
909
910     my $all_applied = 1;
911     foreach (@upgradescripts) {
912       if (!$_->{"applied"}) {
913         $all_applied = 0;
914         last;
915       }
916     }
917
918     next if ($all_applied);
919
920     foreach my $control (@upgradescripts) {
921       next if ($control->{"applied"});
922
923       $control->{description} = SL::Iconv::convert($control->{charset}, $db_charset, $control->{description});
924
925       $control->{"file"} =~ /\.(sql|pl)$/;
926       my $file_type = $1;
927
928       # apply upgrade
929       $main::lxdebug->message(DEBUG2, "Applying Update $control->{file}");
930       print($form->parse_html_template("dbupgrade/upgrade_message2",
931                                        $control));
932
933       if ($file_type eq "sql") {
934         $self->process_query($form, $dbh, "sql/" . $form->{"dbdriver"} .
935                              "-upgrade2/$control->{file}", $control, $db_charset);
936       } else {
937         $self->process_perl_script($form, $dbh, "sql/" . $form->{"dbdriver"} .
938                                    "-upgrade2/$control->{file}", $control, $db_charset);
939       }
940     }
941
942     $rc = 0;
943     $dbh->disconnect;
944
945   }
946
947   $main::lxdebug->leave_sub();
948
949   return $rc;
950 }
951
952 sub update2_available {
953   $main::lxdebug->enter_sub();
954
955   my ($form, $controls) = @_;
956
957   map({ $_->{"applied"} = 0; } values(%{$controls}));
958
959   dbconnect_vars($form, $form->{"dbname"});
960
961   my $dbh =
962     DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) ||
963     $form->dberror;
964
965   my ($query, $tag, $sth);
966
967   $query = qq|SELECT tag FROM schema_info|;
968   $sth = $dbh->prepare($query);
969   $sth->execute() || $form->dberror($query);
970   while (($tag) = $sth->fetchrow_array()) {
971     $controls->{$tag}->{"applied"} = 1 if (defined($controls->{$tag}));
972   }
973   $sth->finish();
974   $dbh->disconnect();
975
976   map({ $main::lxdebug->leave_sub() and return 1 if (!$_->{"applied"}) }
977       values(%{$controls}));
978
979   $main::lxdebug->leave_sub();
980   return 0;
981 }
982
983 sub create_config {
984   $main::lxdebug->enter_sub();
985
986   my ($self) = @_;
987
988   local *CONF;
989
990   @config = config_vars();
991
992   my $userspath = $main::userspath;
993
994   open(CONF, ">", "$userspath/$self->{login}.conf") || $self->error("$userspath/$self->{login}.conf : $!");
995
996   # create the config file
997   print CONF qq|# configuration file for $self->{login}
998
999 \%myconfig = (
1000 |;
1001
1002   foreach my $key (sort @config) {
1003     $self->{$key} =~ s/\'/\\\'/g;
1004     print CONF qq|  $key => '$self->{$key}',\n|;
1005   }
1006
1007   print CONF qq|);\n\n|;
1008
1009   close CONF;
1010
1011   $main::lxdebug->leave_sub();
1012 }
1013
1014 sub save_member {
1015   $main::lxdebug->enter_sub();
1016
1017   my ($self, $memberfile, $userspath) = @_;
1018
1019   local (*FH, *CONF);
1020
1021   my $newmember = 1;
1022
1023   # format dbconnect and dboptions string
1024   &dbconnect_vars($self, $self->{dbname});
1025
1026   $self->error('File locked!') if (-f "${memberfile}.LCK");
1027   open(FH, ">${memberfile}.LCK") or $self->error("${memberfile}.LCK : $!");
1028   close(FH);
1029
1030   open(CONF, "+<$memberfile") or $self->error("$memberfile : $!");
1031
1032   @config = <CONF>;
1033
1034   seek(CONF, 0, 0);
1035   truncate(CONF, 0);
1036
1037   while ($line = shift @config) {
1038     if ($line =~ /^\[$self->{login}\]/) {
1039       $newmember = 0;
1040       last;
1041     }
1042     print CONF $line;
1043   }
1044
1045   # remove everything up to next login or EOF
1046   while ($line = shift @config) {
1047     last if ($line =~ /^\[/);
1048   }
1049
1050   # this one is either the next login or EOF
1051   print CONF $line;
1052
1053   while ($line = shift @config) {
1054     print CONF $line;
1055   }
1056
1057   print CONF qq|[$self->{login}]\n|;
1058
1059   if ((($self->{dbpasswd} ne $self->{old_dbpasswd}) || $newmember)
1060       && $self->{root}) {
1061     $self->{dbpasswd} = pack 'u', $self->{dbpasswd};
1062     chop $self->{dbpasswd};
1063   }
1064   if (defined($self->{new_password})) {
1065     if ($self->{new_password} ne $self->{old_password}) {
1066       $self->{password} = crypt $self->{new_password},
1067         substr($self->{login}, 0, 2)
1068         if $self->{new_password};
1069     }
1070   } else {
1071     if ($self->{password} ne $self->{old_password}) {
1072       $self->{password} = crypt $self->{password}, substr($self->{login}, 0, 2)
1073         if $self->{password};
1074     }
1075   }
1076
1077   if ($self->{'root login'}) {
1078     @config = ("password");
1079   } else {
1080     @config = &config_vars;
1081   }
1082
1083   # replace \r\n with \n
1084   map { $self->{$_} =~ s/\r\n/\\n/g } qw(address signature);
1085   foreach $key (sort @config) {
1086     print CONF qq|$key=$self->{$key}\n|;
1087   }
1088
1089   print CONF "\n";
1090   close CONF;
1091   unlink "${memberfile}.LCK";
1092
1093   # create conf file
1094   $self->create_config() unless $self->{'root login'};
1095
1096   $main::lxdebug->leave_sub();
1097 }
1098
1099 sub config_vars {
1100   $main::lxdebug->enter_sub();
1101
1102   my @conf = qw(acs address admin businessnumber company countrycode
1103     currency dateformat dbconnect dbdriver dbhost dbport dboptions
1104     dbname dbuser dbpasswd email fax name numberformat password
1105     printer role sid signature stylesheet tel templates vclimit angebote
1106     bestellungen rechnungen anfragen lieferantenbestellungen einkaufsrechnungen
1107     taxnumber co_ustid duns menustyle template_format default_media
1108     default_printer_id copies show_form_details);
1109
1110   $main::lxdebug->leave_sub();
1111
1112   return @conf;
1113 }
1114
1115 sub error {
1116   $main::lxdebug->enter_sub();
1117
1118   my ($self, $msg) = @_;
1119
1120   $main::lxdebug->show_backtrace();
1121
1122   if ($ENV{HTTP_USER_AGENT}) {
1123     print qq|Content-Type: text/html
1124
1125 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN">
1126
1127 <body bgcolor=ffffff>
1128
1129 <h2><font color=red>Error!</font></h2>
1130 <p><b>$msg</b>|;
1131
1132   }
1133
1134   die "Error: $msg\n";
1135
1136   $main::lxdebug->leave_sub();
1137 }
1138
1139 1;
1140