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 sub new {
  38   $main::lxdebug->enter_sub();
  39
  40   my ($type, $memfile, $login) = @_;
  41   my $self = {};
  42
  43   if ($login ne "") {
  44     &error("", "$memfile locked!") if (-f "${memfile}.LCK");
  45
  46     open(MEMBER, "$memfile") or &error("", "$memfile : $!");
  47
  48     while (<MEMBER>) {
  49       if (/^\[$login\]/) {
  50         while (<MEMBER>) {
  51           last if /^\[/;
  52           next if /^(#|\s)/;
  53
  54           # remove comments
  55           s/\s#.*//g;
  56
  57           # remove any trailing whitespace
  58           s/^\s*(.*?)\s*$/$1/;
  59
  60           ($key, $value) = split /=/, $_, 2;
  61
  62           if (($key eq "stylesheet") && ($value eq "sql-ledger.css")) {
  63             $value = "lx-office-erp.css";
  64           }
  65
  66           $self->{$key} = $value;
  67         }
  68
  69         $self->{login} = $login;
  70
  71         last;
  72       }
  73     }
  74     close MEMBER;
  75   }
  76
  77   $main::lxdebug->leave_sub();
  78   bless $self, $type;
  79 }
  80
  81 sub country_codes {
  82   $main::lxdebug->enter_sub();
  83
  84   my %cc       = ();
  85   my @language = ();
  86
  87   # scan the locale directory and read in the LANGUAGE files
  88   opendir DIR, "locale";
  89
  90   my @dir = grep !/(^\.\.?$|\..*)/, readdir DIR;
  91
  92   foreach my $dir (@dir) {
  93     next unless open(FH, "locale/$dir/LANGUAGE");
  94     @language = <FH>;
  95     close FH;
  96
  97     $cc{$dir} = "@language";
  98   }
  99
 100   closedir(DIR);
 101
 102   $main::lxdebug->leave_sub();
 103
 104   return %cc;
 105 }
 106
 107 sub login {
 108   $main::lxdebug->enter_sub();
 109
 110   my ($self, $form, $userspath) = @_;
 111
 112   my $rc = -3;
 113
 114   if ($self->{login}) {
 115
 116     if ($self->{password}) {
 117       $form->{password} = crypt $form->{password},
 118         substr($self->{login}, 0, 2);
 119       if ($self->{password} ne $form->{password}) {
 120         $main::lxdebug->leave_sub();
 121         return -1;
 122       }
 123     }
 124
 125     unless (-e "$userspath/$self->{login}.conf") {
 126       $self->create_config("$userspath/$self->{login}.conf");
 127     }
 128
 129     do "$userspath/$self->{login}.conf";
 130     $myconfig{dbpasswd} = unpack 'u', $myconfig{dbpasswd};
 131
 132     # check if database is down
 133     my $dbh =
 134       DBI->connect($myconfig{dbconnect}, $myconfig{dbuser},
 135                    $myconfig{dbpasswd})
 136       or $self->error(DBI::errstr);
 137
 138     # we got a connection, check the version
 139     my $query = qq|SELECT version FROM defaults|;
 140     my $sth   = $dbh->prepare($query);
 141     $sth->execute || $form->dberror($query);
 142
 143     my ($dbversion) = $sth->fetchrow_array;
 144     $sth->finish;
 145
 146     # add login to employee table if it does not exist
 147     # no error check for employee table, ignore if it does not exist
 148     $query = qq|SELECT e.id FROM employee e WHERE e.login = '$self->{login}'|;
 149     $sth   = $dbh->prepare($query);
 150     $sth->execute;
 151
 152     my ($login) = $sth->fetchrow_array;
 153     $sth->finish;
 154
 155     if (!$login) {
 156       $query = qq|INSERT INTO employee (login, name, workphone, role)
 157                   VALUES ('$self->{login}', '$myconfig{name}',
 158                   '$myconfig{tel}', 'user')|;
 159       $dbh->do($query);
 160     }
 161     $dbh->disconnect;
 162
 163     $rc = 0;
 164
 165     if ($form->{dbversion} ne $dbversion) {
 166
 167       # update the tables
 168       open FH, ">$userspath/nologin" or die "
 169 $!";
 170
 171       map { $form->{$_} = $myconfig{$_} }
 172         qw(dbname dbhost dbport dbdriver dbuser dbpasswd);
 173
 174       $form->{dbupdate} = "db$myconfig{dbname}";
 175       $form->{ $form->{dbupdate} } = 1;
 176
 177       $form->info("Upgrading Dataset $myconfig{dbname} ...");
 178
 179       # required for Oracle
 180       $form->{dbdefault} = $sid;
 181
 182       # ignore HUP, QUIT in case the webserver times out
 183       $SIG{HUP}  = 'IGNORE';
 184       $SIG{QUIT} = 'IGNORE';
 185
 186       $self->dbupdate($form);
 187
 188       # remove lock file
 189       unlink "$userspath/nologin";
 190
 191       $form->info("... done");
 192
 193       $rc = -2;
 194
 195     }
 196   }
 197
 198   $main::lxdebug->leave_sub();
 199
 200   return $rc;
 201 }
 202
 203 sub dbconnect_vars {
 204   $main::lxdebug->enter_sub();
 205
 206   my ($form, $db) = @_;
 207
 208   my %dboptions = (
 209         'Pg' => { 'yy-mm-dd'   => 'set DateStyle to \'ISO\'',
 210                   'yyyy-mm-dd' => 'set DateStyle to \'ISO\'',
 211                   'mm/dd/yy'   => 'set DateStyle to \'SQL, US\'',
 212                   'mm-dd-yy'   => 'set DateStyle to \'POSTGRES, US\'',
 213                   'dd/mm/yy'   => 'set DateStyle to \'SQL, EUROPEAN\'',
 214                   'dd-mm-yy'   => 'set DateStyle to \'POSTGRES, EUROPEAN\'',
 215                   'dd.mm.yy'   => 'set DateStyle to \'GERMAN\''
 216         },
 217         'Oracle' => {
 218           'yy-mm-dd'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'YY-MM-DD\'',
 219           'yyyy-mm-dd' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'YYYY-MM-DD\'',
 220           'mm/dd/yy'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'MM/DD/YY\'',
 221           'mm-dd-yy'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'MM-DD-YY\'',
 222           'dd/mm/yy'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD/MM/YY\'',
 223           'dd-mm-yy'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD-MM-YY\'',
 224           'dd.mm.yy'   => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD.MM.YY\'',
 225         });
 226
 227   $form->{dboptions} = $dboptions{ $form->{dbdriver} }{ $form->{dateformat} };
 228
 229   if ($form->{dbdriver} eq 'Pg') {
 230     $form->{dbconnect} = "dbi:Pg:dbname=$db";
 231   }
 232
 233   if ($form->{dbdriver} eq 'Oracle') {
 234     $form->{dbconnect} = "dbi:Oracle:sid=$form->{sid}";
 235   }
 236
 237   if ($form->{dbhost}) {
 238     $form->{dbconnect} .= ";host=$form->{dbhost}";
 239   }
 240   if ($form->{dbport}) {
 241     $form->{dbconnect} .= ";port=$form->{dbport}";
 242   }
 243
 244   $main::lxdebug->leave_sub();
 245 }
 246
 247 sub dbdrivers {
 248   $main::lxdebug->enter_sub();
 249
 250   my @drivers = DBI->available_drivers();
 251
 252   $main::lxdebug->leave_sub();
 253
 254   return (grep { /(Pg|Oracle)/ } @drivers);
 255 }
 256
 257 sub dbsources {
 258   $main::lxdebug->enter_sub();
 259
 260   my ($self, $form) = @_;
 261
 262   my @dbsources = ();
 263   my ($sth, $query);
 264
 265   $form->{dbdefault} = $form->{dbuser} unless $form->{dbdefault};
 266   $form->{sid} = $form->{dbdefault};
 267   &dbconnect_vars($form, $form->{dbdefault});
 268
 269   my $dbh =
 270     DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
 271     or $form->dberror;
 272
 273   if ($form->{dbdriver} eq 'Pg') {
 274
 275     $query = qq|SELECT datname FROM pg_database|;
 276     $sth   = $dbh->prepare($query);
 277     $sth->execute || $form->dberror($query);
 278
 279     while (my ($db) = $sth->fetchrow_array) {
 280
 281       if ($form->{only_acc_db}) {
 282
 283         next if ($db =~ /^template/);
 284
 285         &dbconnect_vars($form, $db);
 286         my $dbh =
 287           DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
 288           or $form->dberror;
 289
 290         $query = qq|SELECT p.tablename FROM pg_tables p
 291                     WHERE p.tablename = 'defaults'
 292                     AND p.tableowner = '$form->{dbuser}'|;
 293         my $sth = $dbh->prepare($query);
 294         $sth->execute || $form->dberror($query);
 295
 296         if ($sth->fetchrow_array) {
 297           push @dbsources, $db;
 298         }
 299         $sth->finish;
 300         $dbh->disconnect;
 301         next;
 302       }
 303       push @dbsources, $db;
 304     }
 305   }
 306
 307   if ($form->{dbdriver} eq 'Oracle') {
 308     if ($form->{only_acc_db}) {
 309       $query = qq|SELECT o.owner FROM dba_objects o
 310                   WHERE o.object_name = 'DEFAULTS'
 311                   AND o.object_type = 'TABLE'|;
 312     } else {
 313       $query = qq|SELECT username FROM dba_users|;
 314     }
 315
 316     $sth = $dbh->prepare($query);
 317     $sth->execute || $form->dberror($query);
 318
 319     while (my ($db) = $sth->fetchrow_array) {
 320       push @dbsources, $db;
 321     }
 322   }
 323
 324   $sth->finish;
 325   $dbh->disconnect;
 326
 327   $main::lxdebug->leave_sub();
 328
 329   return @dbsources;
 330 }
 331
 332 sub dbcreate {
 333   $main::lxdebug->enter_sub();
 334
 335   my ($self, $form) = @_;
 336
 337   my %dbcreate = (
 338     'Pg'     => qq|CREATE DATABASE "$form->{db}"|,
 339     'Oracle' =>
 340       qq|CREATE USER "$form->{db}" DEFAULT TABLESPACE USERS TEMPORARY TABLESPACE TEMP IDENTIFIED BY "$form->{db}"|
 341   );
 342
 343   $dbcreate{Pg} .= " WITH ENCODING = '$form->{encoding}'" if $form->{encoding};
 344
 345   $form->{sid} = $form->{dbdefault};
 346   &dbconnect_vars($form, $form->{dbdefault});
 347   my $dbh =
 348     DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
 349     or $form->dberror;
 350   my $query = qq|$dbcreate{$form->{dbdriver}}|;
 351   $dbh->do($query) || $form->dberror($query);
 352
 353   if ($form->{dbdriver} eq 'Oracle') {
 354     $query = qq|GRANT CONNECT,RESOURCE TO "$form->{db}"|;
 355     $dbh->do($query) || $form->dberror($query);
 356   }
 357   $dbh->disconnect;
 358
 359   # setup variables for the new database
 360   if ($form->{dbdriver} eq 'Oracle') {
 361     $form->{dbuser}   = $form->{db};
 362     $form->{dbpasswd} = $form->{db};
 363   }
 364
 365   &dbconnect_vars($form, $form->{db});
 366
 367   $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
 368     or $form->dberror;
 369
 370   # create the tables
 371   my $filename = qq|sql/lx-office.sql|;
 372   $self->process_query($form, $dbh, $filename);
 373
 374   # load gifi
 375   ($filename) = split /_/, $form->{chart};
 376   $filename =~ s/_//;
 377   $self->process_query($form, $dbh, "sql/${filename}-gifi.sql");
 378
 379   # load chart of accounts
 380   $filename = qq|sql/$form->{chart}-chart.sql|;
 381   $self->process_query($form, $dbh, $filename);
 382
 383   # create indices
 384   # Indices sind auch in lx-office.sql
 385   # $filename = qq|sql/$form->{dbdriver}-indices.sql|;
 386   # $self->process_query($form, $dbh, $filename);
 387
 388   $dbh->disconnect;
 389
 390   $main::lxdebug->leave_sub();
 391 }
 392
 393 sub process_query {
 394   $main::lxdebug->enter_sub();
 395
 396   my ($self, $form, $dbh, $filename) = @_;
 397
 398   #  return unless (-f $filename);
 399
 400   open(FH, "$filename") or $form->error("$filename : $!\n");
 401   my $query = "";
 402   my $sth;
 403   my @quote_chars;
 404
 405   while (<FH>) {
 406
 407     # Remove DOS and Unix style line endings.
 408     s/[\r\n]//g;
 409
 410     # don't add comments or empty lines
 411     next if /^(--.*|\s+)$/;
 412
 413     for (my $i = 0; $i < length($_); $i++) {
 414       my $char = substr($_, $i, 1);
 415
 416       # Are we inside a string?
 417       if (@quote_chars) {
 418         if ($char eq $quote_chars[-1]) {
 419           pop(@quote_chars);
 420         }
 421         $query .= $char;
 422
 423       } else {
 424         if (($char eq "'") || ($char eq "\"")) {
 425           push(@quote_chars, $char);
 426
 427         } elsif ($char eq ";") {
 428
 429           # Query is complete. Send it.
 430
 431           $sth = $dbh->prepare($query);
 432           $sth->execute || $form->dberror($query);
 433           $sth->finish;
 434
 435           $char  = "";
 436           $query = "";
 437         }
 438
 439         $query .= $char;
 440       }
 441     }
 442   }
 443
 444   close FH;
 445
 446   $main::lxdebug->leave_sub();
 447 }
 448
 449 sub dbdelete {
 450   $main::lxdebug->enter_sub();
 451
 452   my ($self, $form) = @_;
 453
 454   my %dbdelete = ('Pg'     => qq|DROP DATABASE "$form->{db}"|,
 455                   'Oracle' => qq|DROP USER $form->{db} CASCADE|);
 456
 457   $form->{sid} = $form->{dbdefault};
 458   &dbconnect_vars($form, $form->{dbdefault});
 459   my $dbh =
 460     DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
 461     or $form->dberror;
 462   my $query = qq|$dbdelete{$form->{dbdriver}}|;
 463   $dbh->do($query) || $form->dberror($query);
 464
 465   $dbh->disconnect;
 466
 467   $main::lxdebug->leave_sub();
 468 }
 469
 470 sub dbsources_unused {
 471   $main::lxdebug->enter_sub();
 472
 473   my ($self, $form, $memfile) = @_;
 474
 475   my @dbexcl    = ();
 476   my @dbsources = ();
 477
 478   $form->error('File locked!') if (-f "${memfile}.LCK");
 479
 480   # open members file
 481   open(FH, "$memfile") or $form->error("$memfile : $!");
 482
 483   while (<FH>) {
 484     if (/^dbname=/) {
 485       my ($null, $item) = split /=/;
 486       push @dbexcl, $item;
 487     }
 488   }
 489
 490   close FH;
 491
 492   $form->{only_acc_db} = 1;
 493   my @db = &dbsources("", $form);
 494
 495   push @dbexcl, $form->{dbdefault};
 496
 497   foreach $item (@db) {
 498     unless (grep /$item$/, @dbexcl) {
 499       push @dbsources, $item;
 500     }
 501   }
 502
 503   $main::lxdebug->leave_sub();
 504
 505   return @dbsources;
 506 }
 507
 508 sub dbneedsupdate {
 509   $main::lxdebug->enter_sub();
 510
 511   my ($self, $form) = @_;
 512
 513   my %dbsources = ();
 514   my $query;
 515
 516   $form->{sid} = $form->{dbdefault};
 517   &dbconnect_vars($form, $form->{dbdefault});
 518
 519   my $dbh =
 520     DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
 521     or $form->dberror;
 522
 523   if ($form->{dbdriver} eq 'Pg') {
 524
 525     $query = qq|SELECT d.datname FROM pg_database d, pg_user u
 526                 WHERE d.datdba = u.usesysid
 527                 AND u.usename = '$form->{dbuser}'|;
 528     my $sth = $dbh->prepare($query);
 529     $sth->execute || $form->dberror($query);
 530
 531     while (my ($db) = $sth->fetchrow_array) {
 532
 533       next if ($db =~ /^template/);
 534
 535       &dbconnect_vars($form, $db);
 536
 537       my $dbh =
 538         DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
 539         or $form->dberror;
 540
 541       $query = qq|SELECT t.tablename FROM pg_tables t
 542                   WHERE t.tablename = 'defaults'|;
 543       my $sth = $dbh->prepare($query);
 544       $sth->execute || $form->dberror($query);
 545
 546       if ($sth->fetchrow_array) {
 547         $query = qq|SELECT version FROM defaults|;
 548         my $sth = $dbh->prepare($query);
 549         $sth->execute;
 550
 551         if (my ($version) = $sth->fetchrow_array) {
 552           $dbsources{$db} = $version;
 553         }
 554         $sth->finish;
 555       }
 556       $sth->finish;
 557       $dbh->disconnect;
 558     }
 559     $sth->finish;
 560   }
 561
 562   if ($form->{dbdriver} eq 'Oracle') {
 563     $query = qq|SELECT o.owner FROM dba_objects o
 564                 WHERE o.object_name = 'DEFAULTS'
 565                 AND o.object_type = 'TABLE'|;
 566
 567     $sth = $dbh->prepare($query);
 568     $sth->execute || $form->dberror($query);
 569
 570     while (my ($db) = $sth->fetchrow_array) {
 571
 572       $form->{dbuser} = $db;
 573       &dbconnect_vars($form, $db);
 574
 575       my $dbh =
 576         DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
 577         or $form->dberror;
 578
 579       $query = qq|SELECT version FROM defaults|;
 580       my $sth = $dbh->prepare($query);
 581       $sth->execute;
 582
 583       if (my ($version) = $sth->fetchrow_array) {
 584         $dbsources{$db} = $version;
 585       }
 586       $sth->finish;
 587       $dbh->disconnect;
 588     }
 589     $sth->finish;
 590   }
 591
 592   $dbh->disconnect;
 593
 594   $main::lxdebug->leave_sub();
 595
 596   return %dbsources;
 597 }
 598
 599 ## LINET
 600 sub calc_version {
 601   $main::lxdebug->enter_sub();
 602
 603   my (@v, $version, $i);
 604
 605   @v = split(/\./, $_[0]);
 606   while (scalar(@v) < 4) {
 607     push(@v, 0);
 608   }
 609   $version = 0;
 610   for ($i = 0; $i < 4; $i++) {
 611     $version *= 1000;
 612     $version += $v[$i];
 613   }
 614
 615   $main::lxdebug->leave_sub();
 616   return $version;
 617 }
 618
 619 sub cmp_script_version {
 620   my ($a_from, $a_to, $b_from, $b_to);
 621   my ($i, $res_a, $res_b);
 622   my ($my_a, $my_b) = ($a, $b);
 623
 624   $my_a =~ s/.*-upgrade-//;
 625   $my_a =~ s/.sql$//;
 626   $my_b =~ s/.*-upgrade-//;
 627   $my_b =~ s/.sql$//;
 628   ($my_a_from, $my_a_to) = split(/-/, $my_a);
 629   ($my_b_from, $my_b_to) = split(/-/, $my_b);
 630
 631   $res_a = calc_version($my_a_from);
 632   $res_b = calc_version($my_b_from);
 633
 634   if ($res_a == $res_b) {
 635     $res_a = calc_version($my_a_to);
 636     $res_b = calc_version($my_b_to);
 637   }
 638
 639   return $res_a <=> $res_b;
 640 }
 641 ## /LINET
 642
 643 sub dbupdate {
 644   $main::lxdebug->enter_sub();
 645
 646   my ($self, $form) = @_;
 647
 648   $form->{sid} = $form->{dbdefault};
 649
 650   my @upgradescripts = ();
 651   my $query;
 652   my $rc = -2;
 653
 654   if ($form->{dbupdate}) {
 655
 656     # read update scripts into memory
 657     opendir SQLDIR, "sql/." or $form - error($!);
 658     ## LINET
 659     @upgradescripts =
 660       sort(cmp_script_version
 661            grep(/$form->{dbdriver}-upgrade-.*?\.sql$/, readdir(SQLDIR)));
 662     ## /LINET
 663     closedir SQLDIR;
 664   }
 665
 666   foreach my $db (split / /, $form->{dbupdate}) {
 667
 668     next unless $form->{$db};
 669
 670     # strip db from dataset
 671     $db =~ s/^db//;
 672     &dbconnect_vars($form, $db);
 673
 674     my $dbh =
 675       DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
 676       or $form->dberror;
 677
 678     # check version
 679     $query = qq|SELECT version FROM defaults|;
 680     my $sth = $dbh->prepare($query);
 681
 682     # no error check, let it fall through
 683     $sth->execute;
 684
 685     my $version = $sth->fetchrow_array;
 686     $sth->finish;
 687
 688     next unless $version;
 689
 690     ## LINET
 691     $version = calc_version($version);
 692     ## /LINET
 693
 694     foreach my $upgradescript (@upgradescripts) {
 695       my $a = $upgradescript;
 696       $a =~ s/^$form->{dbdriver}-upgrade-|\.sql$//g;
 697
 698       my ($mindb, $maxdb) = split /-/, $a;
 699       ## LINET
 700       $mindb = calc_version($mindb);
 701       $maxdb = calc_version($maxdb);
 702       ## /LINET
 703
 704       next if ($version >= $maxdb);
 705
 706       # if there is no upgrade script exit
 707       last if ($version < $mindb);
 708
 709       # apply upgrade
 710       $self->process_query($form, $dbh, "sql/$upgradescript");
 711
 712       $version = $maxdb;
 713
 714     }
 715
 716     $rc = 0;
 717     $dbh->disconnect;
 718
 719   }
 720
 721   $main::lxdebug->leave_sub();
 722
 723   return $rc;
 724 }
 725
 726 sub create_config {
 727   $main::lxdebug->enter_sub();
 728
 729   my ($self, $filename) = @_;
 730
 731   @config = &config_vars;
 732
 733   open(CONF, ">$filename") or $self->error("$filename : $!");
 734
 735   # create the config file
 736   print CONF qq|# configuration file for $self->{login}
 737
 738 \%myconfig = (
 739 |;
 740
 741   foreach $key (sort @config) {
 742     $self->{$key} =~ s/\'/\\\'/g;
 743     print CONF qq|  $key => '$self->{$key}',\n|;
 744   }
 745
 746   print CONF qq|);\n\n|;
 747
 748   close CONF;
 749
 750   $main::lxdebug->leave_sub();
 751 }
 752
 753 sub save_member {
 754   $main::lxdebug->enter_sub();
 755
 756   my ($self, $memberfile, $userspath) = @_;
 757
 758   my $newmember = 1;
 759
 760   # format dbconnect and dboptions string
 761   &dbconnect_vars($self, $self->{dbname});
 762
 763   $self->error('File locked!') if (-f "${memberfile}.LCK");
 764   open(FH, ">${memberfile}.LCK") or $self->error("${memberfile}.LCK : $!");
 765   close(FH);
 766
 767   open(CONF, "+<$memberfile") or $self->error("$memberfile : $!");
 768
 769   @config = <CONF>;
 770
 771   seek(CONF, 0, 0);
 772   truncate(CONF, 0);
 773
 774   while ($line = shift @config) {
 775     if ($line =~ /^\[$self->{login}\]/) {
 776       $newmember = 0;
 777       last;
 778     }
 779     print CONF $line;
 780   }
 781
 782   # remove everything up to next login or EOF
 783   while ($line = shift @config) {
 784     last if ($line =~ /^\[/);
 785   }
 786
 787   # this one is either the next login or EOF
 788   print CONF $line;
 789
 790   while ($line = shift @config) {
 791     print CONF $line;
 792   }
 793
 794   print CONF qq|[$self->{login}]\n|;
 795
 796   if ((($self->{dbpasswd} ne $self->{old_dbpasswd}) || $newmember)
 797       && $self->{root}) {
 798     $self->{dbpasswd} = pack 'u', $self->{dbpasswd};
 799     chop $self->{dbpasswd};
 800   }
 801   if (defined($self->{new_password})) {
 802     if ($self->{new_password} ne $self->{old_password}) {
 803       $self->{password} = crypt $self->{new_password},
 804         substr($self->{login}, 0, 2)
 805         if $self->{new_password};
 806     }
 807   } else {
 808     if ($self->{password} ne $self->{old_password}) {
 809       $self->{password} = crypt $self->{password}, substr($self->{login}, 0, 2)
 810         if $self->{password};
 811     }
 812   }
 813
 814   if ($self->{'root login'}) {
 815     @config = ("password");
 816   } else {
 817     @config = &config_vars;
 818   }
 819
 820   # replace \r\n with \n
 821   map { $self->{$_} =~ s/\r\n/\\n/g } qw(address signature);
 822   foreach $key (sort @config) {
 823     print CONF qq|$key=$self->{$key}\n|;
 824   }
 825
 826   print CONF "\n";
 827   close CONF;
 828   unlink "${memberfile}.LCK";
 829
 830   # create conf file
 831   $self->create_config("$userspath/$self->{login}.conf")
 832     unless $self->{'root login'};
 833
 834   $main::lxdebug->leave_sub();
 835 }
 836
 837 sub config_vars {
 838   $main::lxdebug->enter_sub();
 839
 840   my @conf = qw(acs address admin businessnumber charset company countrycode
 841     currency dateformat dbconnect dbdriver dbhost dbport dboptions
 842     dbname dbuser dbpasswd email fax name numberformat password
 843     printer role sid signature stylesheet tel templates vclimit angebote bestellungen rechnungen
 844     anfragen lieferantenbestellungen einkaufsrechnungen steuernummer ustid duns);
 845
 846   $main::lxdebug->leave_sub();
 847
 848   return @conf;
 849 }
 850
 851 sub error {
 852   $main::lxdebug->enter_sub();
 853
 854   my ($self, $msg) = @_;
 855
 856   if ($ENV{HTTP_USER_AGENT}) {
 857     print qq|Content-Type: text/html
 858
 859 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN">
 860
 861 <body bgcolor=ffffff>
 862
 863 <h2><font color=red>Error!</font></h2>
 864 <p><b>$msg</b>|;
 865
 866   }
 867
 868   die "Error: $msg\n";
 869
 870   $main::lxdebug->leave_sub();
 871 }
 872
 873 1;
 874