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