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     $query =
 763       qq|CREATE TABLE schema_info (| .
 764       qq|  tag text, | .
 765       qq|  login text, | .
 766       qq|  itime timestamp DEFAULT now(), | .
 767       qq|  PRIMARY KEY (tag))|;
 768     $dbh->do($query) || $form->dberror($query);
 769   }
 770
 771   $main::lxdebug->leave_sub();
 772 }
 773
 774 sub dbupdate {
 775   $main::lxdebug->enter_sub();
 776
 777   my ($self, $form) = @_;
 778
 779   $form->{sid} = $form->{dbdefault};
 780
 781   my @upgradescripts = ();
 782   my $query;
 783   my $rc = -2;
 784
 785   if ($form->{dbupdate}) {
 786
 787     # read update scripts into memory
 788     opendir(SQLDIR, "sql/" . $form->{dbdriver} . "-upgrade")
 789       or &error("", "sql/" . $form->{dbdriver} . "-upgrade : $!");
 790     @upgradescripts =
 791       sort(cmp_script_version
 792            grep(/$form->{dbdriver}-upgrade-.*?\.(sql|pl)$/,
 793                 readdir(SQLDIR)));
 794     closedir(SQLDIR);
 795   }
 796
 797   foreach my $db (split(/ /, $form->{dbupdate})) {
 798
 799     next unless $form->{$db};
 800
 801     # strip db from dataset
 802     $db =~ s/^db//;
 803     &dbconnect_vars($form, $db);
 804
 805     my $dbh =
 806       DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
 807       or $form->dberror;
 808
 809     # check version
 810     $query = qq|SELECT version FROM defaults|;
 811     my ($version) = selectrow_query($form, $dbh, $query);
 812
 813     next unless $version;
 814
 815     $version = calc_version($version);
 816
 817     foreach my $upgradescript (@upgradescripts) {
 818       my $a = $upgradescript;
 819       $a =~ s/^$form->{dbdriver}-upgrade-|\.(sql|pl)$//g;
 820       my $file_type = $1;
 821
 822       my ($mindb, $maxdb) = split /-/, $a;
 823       my $str_maxdb = $maxdb;
 824       $mindb = calc_version($mindb);
 825       $maxdb = calc_version($maxdb);
 826
 827       next if ($version >= $maxdb);
 828
 829       # if there is no upgrade script exit
 830       last if ($version < $mindb);
 831
 832       # apply upgrade
 833       $main::lxdebug->message(DEBUG2, "Applying Update $upgradescript");
 834       if ($file_type eq "sql") {
 835         $self->process_query($form, $dbh, "sql/" . $form->{"dbdriver"} .
 836                              "-upgrade/$upgradescript", $str_maxdb);
 837       } else {
 838         $self->process_perl_script($form, $dbh, "sql/" . $form->{"dbdriver"} .
 839                                    "-upgrade/$upgradescript", $str_maxdb);
 840       }
 841
 842       $version = $maxdb;
 843
 844     }
 845
 846     $rc = 0;
 847     $dbh->disconnect;
 848
 849   }
 850
 851   $main::lxdebug->leave_sub();
 852
 853   return $rc;
 854 }
 855
 856 sub dbupdate2 {
 857   $main::lxdebug->enter_sub();
 858
 859   my ($self, $form, $controls) = @_;
 860
 861   $form->{sid} = $form->{dbdefault};
 862
 863   my @upgradescripts = ();
 864   my ($query, $sth, $tag);
 865   my $rc = -2;
 866
 867   @upgradescripts = sort_dbupdate_controls($controls);
 868
 869   foreach my $db (split / /, $form->{dbupdate}) {
 870
 871     next unless $form->{$db};
 872
 873     # strip db from dataset
 874     $db =~ s/^db//;
 875     &dbconnect_vars($form, $db);
 876
 877     my $dbh =
 878       DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
 879       or $form->dberror;
 880
 881     map({ $_->{"applied"} = 0; } @upgradescripts);
 882
 883     $query = qq|SELECT tag FROM schema_info|;
 884     $sth = $dbh->prepare($query);
 885     $sth->execute() || $form->dberror($query);
 886     while (($tag) = $sth->fetchrow_array()) {
 887       $controls->{$tag}->{"applied"} = 1 if (defined($controls->{$tag}));
 888     }
 889     $sth->finish();
 890
 891     my $all_applied = 1;
 892     foreach (@upgradescripts) {
 893       if (!$_->{"applied"}) {
 894         $all_applied = 0;
 895         last;
 896       }
 897     }
 898
 899     next if ($all_applied);
 900
 901     foreach my $control (@upgradescripts) {
 902       next if ($control->{"applied"});
 903
 904       $control->{"file"} =~ /\.(sql|pl)$/;
 905       my $file_type = $1;
 906
 907       # apply upgrade
 908       $main::lxdebug->message(DEBUG2, "Applying Update $control->{file}");
 909       print($form->parse_html_template("dbupgrade/upgrade_message2",
 910                                        $control));
 911
 912       if ($file_type eq "sql") {
 913         $self->process_query($form, $dbh, "sql/" . $form->{"dbdriver"} .
 914                              "-upgrade2/$control->{file}", $control);
 915       } else {
 916         $self->process_perl_script($form, $dbh, "sql/" . $form->{"dbdriver"} .
 917                                    "-upgrade2/$control->{file}", $control);
 918       }
 919     }
 920
 921     $rc = 0;
 922     $dbh->disconnect;
 923
 924   }
 925
 926   $main::lxdebug->leave_sub();
 927
 928   return $rc;
 929 }
 930
 931 sub update2_available {
 932   $main::lxdebug->enter_sub();
 933
 934   my ($form, $controls) = @_;
 935
 936   map({ $_->{"applied"} = 0; } values(%{$controls}));
 937
 938   dbconnect_vars($form, $form->{"dbname"});
 939
 940   my $dbh =
 941     DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) ||
 942     $form->dberror;
 943
 944   my ($query, $tag, $sth);
 945
 946   $query = qq|SELECT tag FROM schema_info|;
 947   $sth = $dbh->prepare($query);
 948   $sth->execute() || $form->dberror($query);
 949   while (($tag) = $sth->fetchrow_array()) {
 950     $controls->{$tag}->{"applied"} = 1 if (defined($controls->{$tag}));
 951   }
 952   $sth->finish();
 953   $dbh->disconnect();
 954
 955   map({ $main::lxdebug->leave_sub() and return 1 if (!$_->{"applied"}) }
 956       values(%{$controls}));
 957
 958   $main::lxdebug->leave_sub();
 959   return 0;
 960 }
 961
 962 sub create_config {
 963   $main::lxdebug->enter_sub();
 964
 965   my ($self, $filename) = @_;
 966
 967   @config = &config_vars;
 968
 969   open(CONF, ">$filename") or $self->error("$filename : $!");
 970
 971   # create the config file
 972   print CONF qq|# configuration file for $self->{login}
 973
 974 \%myconfig = (
 975 |;
 976
 977   foreach $key (sort @config) {
 978     $self->{$key} =~ s/\'/\\\'/g;
 979     print CONF qq|  $key => '$self->{$key}',\n|;
 980   }
 981
 982   print CONF qq|);\n\n|;
 983
 984   close CONF;
 985
 986   $main::lxdebug->leave_sub();
 987 }
 988
 989 sub save_member {
 990   $main::lxdebug->enter_sub();
 991
 992   my ($self, $memberfile, $userspath) = @_;
 993
 994   my $newmember = 1;
 995
 996   # format dbconnect and dboptions string
 997   &dbconnect_vars($self, $self->{dbname});
 998
 999   $self->error('File locked!') if (-f "${memberfile}.LCK");
1000   open(FH, ">${memberfile}.LCK") or $self->error("${memberfile}.LCK : $!");
1001   close(FH);
1002
1003   open(CONF, "+<$memberfile") or $self->error("$memberfile : $!");
1004
1005   @config = <CONF>;
1006
1007   seek(CONF, 0, 0);
1008   truncate(CONF, 0);
1009
1010   while ($line = shift @config) {
1011     if ($line =~ /^\[$self->{login}\]/) {
1012       $newmember = 0;
1013       last;
1014     }
1015     print CONF $line;
1016   }
1017
1018   # remove everything up to next login or EOF
1019   while ($line = shift @config) {
1020     last if ($line =~ /^\[/);
1021   }
1022
1023   # this one is either the next login or EOF
1024   print CONF $line;
1025
1026   while ($line = shift @config) {
1027     print CONF $line;
1028   }
1029
1030   print CONF qq|[$self->{login}]\n|;
1031
1032   if ((($self->{dbpasswd} ne $self->{old_dbpasswd}) || $newmember)
1033       && $self->{root}) {
1034     $self->{dbpasswd} = pack 'u', $self->{dbpasswd};
1035     chop $self->{dbpasswd};
1036   }
1037   if (defined($self->{new_password})) {
1038     if ($self->{new_password} ne $self->{old_password}) {
1039       $self->{password} = crypt $self->{new_password},
1040         substr($self->{login}, 0, 2)
1041         if $self->{new_password};
1042     }
1043   } else {
1044     if ($self->{password} ne $self->{old_password}) {
1045       $self->{password} = crypt $self->{password}, substr($self->{login}, 0, 2)
1046         if $self->{password};
1047     }
1048   }
1049
1050   if ($self->{'root login'}) {
1051     @config = ("password");
1052   } else {
1053     @config = &config_vars;
1054   }
1055
1056   # replace \r\n with \n
1057   map { $self->{$_} =~ s/\r\n/\\n/g } qw(address signature);
1058   foreach $key (sort @config) {
1059     print CONF qq|$key=$self->{$key}\n|;
1060   }
1061
1062   print CONF "\n";
1063   close CONF;
1064   unlink "${memberfile}.LCK";
1065
1066   # create conf file
1067   $self->create_config("$userspath/$self->{login}.conf")
1068     unless $self->{'root login'};
1069
1070   $main::lxdebug->leave_sub();
1071 }
1072
1073 sub config_vars {
1074   $main::lxdebug->enter_sub();
1075
1076   my @conf = qw(acs address admin businessnumber charset company countrycode
1077     currency dateformat dbconnect dbdriver dbhost dbport dboptions
1078     dbname dbuser dbpasswd email fax name numberformat password
1079     printer role sid signature stylesheet tel templates vclimit angebote
1080     bestellungen rechnungen anfragen lieferantenbestellungen einkaufsrechnungen
1081     taxnumber co_ustid duns menustyle template_format default_media
1082     default_printer_id copies show_form_details);
1083
1084   $main::lxdebug->leave_sub();
1085
1086   return @conf;
1087 }
1088
1089 sub error {
1090   $main::lxdebug->enter_sub();
1091
1092   my ($self, $msg) = @_;
1093
1094   if ($ENV{HTTP_USER_AGENT}) {
1095     print qq|Content-Type: text/html
1096
1097 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN">
1098
1099 <body bgcolor=ffffff>
1100
1101 <h2><font color=red>Error!</font></h2>
1102 <p><b>$msg</b>|;
1103
1104   }
1105
1106   die "Error: $msg\n";
1107
1108   $main::lxdebug->leave_sub();
1109 }
1110
1111 1;
1112