SL/User.pm

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