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