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