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