SL/User.pm

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