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