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