Bei Einkaufs-/Verkaufsmasken sowie bei Debitoren- und Kreditorenbuchungen wird ein...
[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   open(CONF, ">", "$userspath/$self->{login}.conf") || $self->error("$userspath/$self->{login}.conf : $!");
1034
1035   # create the config file
1036   print CONF qq|# configuration file for $self->{login}
1037
1038 \%myconfig = (
1039 |;
1040
1041   foreach my $key (sort @config) {
1042     $self->{$key} =~ s/\'/\\\'/g;
1043     print CONF qq|  $key => '$self->{$key}',\n|;
1044   }
1045
1046   print CONF qq|);\n\n|;
1047
1048   close CONF;
1049
1050   $main::lxdebug->leave_sub();
1051 }
1052
1053 sub save_member {
1054   $main::lxdebug->enter_sub();
1055
1056   my ($self, $memberfile, $userspath) = @_;
1057
1058   local (*FH, *CONF);
1059
1060   my $newmember = 1;
1061
1062   # format dbconnect and dboptions string
1063   &dbconnect_vars($self, $self->{dbname});
1064
1065   $self->error('File locked!') if (-f "${memberfile}.LCK");
1066   open(FH, ">${memberfile}.LCK") or $self->error("${memberfile}.LCK : $!");
1067   close(FH);
1068
1069   open(CONF, "+<$memberfile") or $self->error("$memberfile : $!");
1070
1071   @config = <CONF>;
1072
1073   seek(CONF, 0, 0);
1074   truncate(CONF, 0);
1075
1076   while ($line = shift @config) {
1077     if ($line =~ /^\[$self->{login}\]/) {
1078       $newmember = 0;
1079       last;
1080     }
1081     print CONF $line;
1082   }
1083
1084   # remove everything up to next login or EOF
1085   while ($line = shift @config) {
1086     last if ($line =~ /^\[/);
1087   }
1088
1089   # this one is either the next login or EOF
1090   print CONF $line;
1091
1092   while ($line = shift @config) {
1093     print CONF $line;
1094   }
1095
1096   print CONF qq|[$self->{login}]\n|;
1097
1098   if ((($self->{dbpasswd} ne $self->{old_dbpasswd}) || $newmember)
1099       && $self->{root}) {
1100     $self->{dbpasswd} = pack 'u', $self->{dbpasswd};
1101     chop $self->{dbpasswd};
1102   }
1103   if (defined($self->{new_password})) {
1104     if ($self->{new_password} ne $self->{old_password}) {
1105       $self->{password} = crypt $self->{new_password},
1106         substr($self->{login}, 0, 2)
1107         if $self->{new_password};
1108     }
1109   } else {
1110     if ($self->{password} ne $self->{old_password}) {
1111       $self->{password} = crypt $self->{password}, substr($self->{login}, 0, 2)
1112         if $self->{password};
1113     }
1114   }
1115
1116   if ($self->{'root login'}) {
1117     @config = ("password");
1118   } else {
1119     @config = &config_vars;
1120   }
1121
1122   # replace \r\n with \n
1123   map { $self->{$_} =~ s/\r\n/\\n/g } qw(address signature);
1124   foreach $key (sort @config) {
1125     print CONF qq|$key=$self->{$key}\n|;
1126   }
1127
1128   print CONF "\n";
1129   close CONF;
1130   unlink "${memberfile}.LCK";
1131
1132   # create conf file
1133   $self->create_config() unless $self->{'root login'};
1134
1135   $main::lxdebug->leave_sub();
1136 }
1137
1138 sub config_vars {
1139   $main::lxdebug->enter_sub();
1140
1141   my @conf = qw(acs address admin businessnumber company countrycode
1142     currency dateformat dbconnect dbdriver dbhost dbport dboptions
1143     dbname dbuser dbpasswd email fax name numberformat password
1144     printer role sid signature stylesheet tel templates vclimit angebote
1145     bestellungen rechnungen anfragen lieferantenbestellungen einkaufsrechnungen
1146     taxnumber co_ustid duns menustyle template_format default_media
1147     default_printer_id copies show_form_details);
1148
1149   $main::lxdebug->leave_sub();
1150
1151   return @conf;
1152 }
1153
1154 sub error {
1155   $main::lxdebug->enter_sub();
1156
1157   my ($self, $msg) = @_;
1158
1159   if ($ENV{HTTP_USER_AGENT}) {
1160     print qq|Content-Type: text/html
1161
1162 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN">
1163
1164 <body bgcolor=ffffff>
1165
1166 <h2><font color=red>Error!</font></h2>
1167 <p><b>$msg</b>|;
1168
1169   }
1170
1171   die "Error: $msg\n";
1172
1173   $main::lxdebug->leave_sub();
1174 }
1175
1176 1;
1177