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