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