sql-ledger/old/sql-ledger/SL/User.pm

   1 #=====================================================================
   2 # SQL-Ledger Accounting
   3 # Copyright (C) 2001
   4 #
   5 #  Author: Dieter Simader
   6 #   Email: dsimader@sql-ledger.org
   7 #     Web: http://www.sql-ledger.org
   8 #
   9 #  Contributors:
  10 #
  11 # This program is free software; you can redistribute it and/or modify
  12 # it under the terms of the GNU General Public License as published by
  13 # the Free Software Foundation; either version 2 of the License, or
  14 # (at your option) any later version.
  15 #
  16 # This program is distributed in the hope that it will be useful,
  17 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 # GNU General Public License for more details.
  20 # You should have received a copy of the GNU General Public License
  21 # along with this program; if not, write to the Free Software
  22 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  23 #=====================================================================
  24 #
  25 # user related functions
  26 #
  27 #=====================================================================
  28
  29 package User;
  30
  31
  32 sub new {
  33   my ($type, $memfile, $login) = @_;
  34   my $self = {};
  35
  36   if ($login ne "") {
  37     # check if the file is locked
  38     &error("", "$memfile locked!") if (-f "${memfile}.LCK");
  39
  40     open(MEMBER, "$memfile") or &error("", "$memfile : $!");
  41
  42     while (<MEMBER>) {
  43       if (/^\[$login\]/) {
  44         while (<MEMBER>) {
  45           last if /^\[/;
  46           next if /^(#|\s)/;
  47
  48           # remove comments
  49           s/\s#.*//g;
  50
  51           # remove any trailing whitespace
  52           s/^\s*(.*?)\s*$/$1/;
  53
  54           ($key, $value) = split /=/, $_, 2;
  55
  56           $self->{$key} = $value;
  57         }
  58
  59         $self->{login} = $login;
  60
  61         last;
  62       }
  63     }
  64     close MEMBER;
  65   }
  66
  67   bless $self, $type;
  68 }
  69
  70
  71 sub country_codes {
  72
  73   my %cc = ();
  74   my @language = ();
  75
  76   # scan the locale directory and read in the LANGUAGE files
  77   opendir DIR, "locale";
  78
  79   my @dir = grep !/(^\.\.?$|\..*)/, readdir DIR;
  80
  81   foreach my $dir (@dir) {
  82     next unless open(FH, "locale/$dir/LANGUAGE");
  83     @language = <FH>;
  84     close FH;
  85
  86     $cc{$dir} = "@language";
  87   }
  88
  89   closedir(DIR);
  90
  91   %cc;
  92
  93 }
  94
  95
  96 sub login {
  97   my ($self, $form, $userspath) = @_;
  98
  99
 100   if ($self->{login}) {
 101
 102     if ($self->{password}) {
 103       $form->{password} = crypt $form->{password}, substr($self->{login}, 0, 2);
 104       if ($self->{password} ne $form->{password}) {
 105         return -1;
 106       }
 107     }
 108
 109     unless (-e "$userspath/$self->{login}.conf") {
 110       $self->create_config("$userspath/$self->{login}.conf");
 111     }
 112
 113     do "$userspath/$self->{login}.conf";
 114     $myconfig{dbpasswd} = unpack 'u', $myconfig{dbpasswd};
 115
 116     # check if database is down
 117     my $dbh = DBI->connect($myconfig{dbconnect}, $myconfig{dbuser}, $myconfig{dbpasswd}) or $self->error(DBI::errstr);
 118
 119     # we got a connection, check the version
 120     my $query = qq|SELECT version FROM defaults|;
 121     my $sth = $dbh->prepare($query);
 122     $sth->execute || $form->dberror($query);
 123
 124     my ($dbversion) = $sth->fetchrow_array;
 125     $sth->finish;
 126
 127     # add login to employee table if it does not exist
 128     # no error check for employee table, ignore if it does not exist
 129     $query = qq|SELECT id FROM employee WHERE login = '$self->{login}'|;
 130     $sth = $dbh->prepare($query);
 131     $sth->execute;
 132
 133     my ($login) = $sth->fetchrow_array;
 134     $sth->finish;
 135
 136     if (!$login) {
 137       $query = qq|INSERT INTO employee (login, name, workphone)
 138                   VALUES ('$self->{login}', '$myconfig{name}', '$myconfig{tel}')|;
 139       $dbh->do($query);
 140     }
 141     $dbh->disconnect;
 142
 143     if ($form->{dbversion} ne $dbversion) {
 144       return -2;
 145     }
 146
 147   } else {
 148     return -3;
 149   }
 150
 151 }
 152
 153
 154
 155 sub dbconnect_vars {
 156   my ($form, $db) = @_;
 157
 158   my %dboptions = (
 159      'Pg' => {
 160         'yy-mm-dd' => 'set DateStyle to \'ISO\'',
 161         'mm/dd/yy' => 'set DateStyle to \'SQL, US\'',
 162         'mm-dd-yy' => 'set DateStyle to \'POSTGRES, US\'',
 163         'dd/mm/yy' => 'set DateStyle to \'SQL, EUROPEAN\'',
 164         'dd-mm-yy' => 'set DateStyle to \'POSTGRES, EUROPEAN\'',
 165         'dd.mm.yy' => 'set DateStyle to \'GERMAN\''
 166              },
 167      'Oracle' => {
 168         'yy-mm-dd' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'YY-MM-DD\'',
 169         'mm/dd/yy' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'MM/DD/YY\'',
 170         'mm-dd-yy' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'MM-DD-YY\'',
 171         'dd/mm/yy' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD/MM/YY\'',
 172         'dd-mm-yy' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD-MM-YY\'',
 173         'dd.mm.yy' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD.MM.YY\'',
 174                  }
 175      );
 176
 177   $form->{dboptions} = $dboptions{$form->{dbdriver}}{$form->{dateformat}};
 178
 179   if ($form->{dbdriver} eq 'Pg') {
 180     $form->{dbconnect} = "dbi:Pg:dbname=$db";
 181   }
 182
 183   if ($form->{dbdriver} eq 'Oracle') {
 184     $form->{dbconnect} = "dbi:Oracle:sid=$form->{sid}";
 185   }
 186
 187   if ($form->{dbhost}) {
 188     $form->{dbconnect} .= ";host=$form->{dbhost}";
 189   }
 190   if ($form->{dbport}) {
 191     $form->{dbconnect} .= ";port=$form->{dbport}";
 192   }
 193
 194 }
 195
 196
 197 sub dbdrivers {
 198
 199   my @drivers = DBI->available_drivers();
 200
 201   return (grep { /(Pg|Oracle)$/ } @drivers);
 202
 203 }
 204
 205
 206 sub dbsources {
 207   my ($self, $form) = @_;
 208
 209   my @dbsources = ();
 210   my ($sth, $query);
 211
 212   $form->{dbdefault} = $form->{dbuser} unless $form->{dbdefault};
 213   $form->{sid} = $form->{dbdefault};
 214   &dbconnect_vars($form, $form->{dbdefault});
 215
 216   my $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) or $form->dberror;
 217
 218
 219   if ($form->{dbdriver} eq 'Pg') {
 220
 221     $query = qq|SELECT datname FROM pg_database|;
 222     $sth = $dbh->prepare($query);
 223     $sth->execute || $form->dberror($query);
 224
 225     while (my ($db) = $sth->fetchrow_array) {
 226
 227       if ($form->{only_acc_db}) {
 228
 229         next if ($db =~ /^template/);
 230
 231         &dbconnect_vars($form, $db);
 232         my $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) or $form->dberror;
 233
 234         $query = qq|SELECT tablename FROM pg_tables
 235                     WHERE tablename = 'defaults'
 236                     AND tableowner = '$form->{dbuser}'|;
 237         my $sth = $dbh->prepare($query);
 238         $sth->execute || $form->dberror($query);
 239
 240         if ($sth->fetchrow_array) {
 241           push @dbsources, $db;
 242         }
 243         $sth->finish;
 244         $dbh->disconnect;
 245         next;
 246       }
 247       push @dbsources, $db;
 248     }
 249   }
 250
 251   if ($form->{dbdriver} eq 'Oracle') {
 252     if ($form->{only_acc_db}) {
 253       $query = qq|SELECT owner FROM dba_objects
 254                   WHERE object_name = 'DEFAULTS'
 255                   AND object_type = 'TABLE'|;
 256     } else {
 257       $query = qq|SELECT username FROM dba_users|;
 258     }
 259
 260     $sth = $dbh->prepare($query);
 261     $sth->execute || $form->dberror($query);
 262
 263     while (my ($db) = $sth->fetchrow_array) {
 264       push @dbsources, $db;
 265     }
 266   }
 267
 268   $sth->finish;
 269   $dbh->disconnect;
 270
 271   return @dbsources;
 272
 273 }
 274
 275
 276 sub dbcreate {
 277   my ($self, $form) = @_;
 278
 279   my %dbcreate = ( 'Pg' => qq|CREATE DATABASE "$form->{db}"|,
 280                'Oracle' => qq|CREATE USER "$form->{db}" DEFAULT TABLESPACE USERS TEMPORARY TABLESPACE TEMP IDENTIFIED BY "$form->{db}"|);
 281
 282   $dbcreate{Pg} .= " WITH ENCODING = '$form->{encoding}'" if $form->{encoding};
 283
 284   $form->{sid} = $form->{dbdefault};
 285   &dbconnect_vars($form, $form->{dbdefault});
 286   my $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) or $form->dberror;
 287   my $query = qq|$dbcreate{$form->{dbdriver}}|;
 288   $dbh->do($query) || $form->dberror($query);
 289
 290   if ($form->{dbdriver} eq 'Oracle') {
 291     $query = qq|GRANT CONNECT,RESOURCE TO "$form->{db}"|;
 292     $dbh->do($query) || $form->dberror($query);
 293   }
 294   $dbh->disconnect;
 295
 296
 297   # setup variables for the new database
 298   if ($form->{dbdriver} eq 'Oracle') {
 299     $form->{dbuser} = $form->{db};
 300     $form->{dbpasswd} = $form->{db};
 301   }
 302
 303
 304   &dbconnect_vars($form, $form->{db});
 305
 306   $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) or $form->dberror;
 307
 308   # create the tables
 309   my $filename = qq|sql/$form->{dbdriver}-tables.sql|;
 310   $self->processquery($form, $dbh, $filename);
 311
 312   # load gifi
 313   ($filename) = split /_/, $form->{chart};
 314   $filename =~ s/_//;
 315   $self->processquery($form, $dbh, "sql/${filename}-gifi.sql");
 316
 317   # load chart of accounts
 318   $filename = qq|sql/$form->{chart}-chart.sql|;
 319   $self->processquery($form, $dbh, $filename);
 320
 321   # create indices
 322   $filename = qq|sql/$form->{dbdriver}-indices.sql|;
 323   $self->processquery($form, $dbh, $filename);
 324
 325   $dbh->disconnect;
 326
 327 }
 328
 329
 330
 331 sub processquery {
 332   my ($self, $form, $dbh, $filename) = @_;
 333
 334   return unless (-f $filename);
 335
 336   open(FH, "$filename") or $form->error("$filename : $!\n");
 337   my $query = "";
 338
 339   while (<FH>) {
 340     $query .= $_;
 341
 342     if (/;\s*$/) {
 343       # strip ;... Oracle doesn't like it
 344       $query =~ s/;\s*$//;
 345       $dbh->do($query) || $form->dberror($query);
 346       $query = "";
 347     }
 348   }
 349   close FH;
 350
 351 }
 352
 353
 354
 355 sub dbdelete {
 356   my ($self, $form) = @_;
 357
 358   my %dbdelete = ( 'Pg' => qq|DROP DATABASE "$form->{db}"|,
 359                'Oracle' => qq|DROP USER $form->{db} CASCADE|
 360                  );
 361
 362   $form->{sid} = $form->{dbdefault};
 363   &dbconnect_vars($form, $form->{dbdefault});
 364   my $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) or $form->dberror;
 365   my $query = qq|$dbdelete{$form->{dbdriver}}|;
 366   $dbh->do($query) || $form->dberror($query);
 367
 368   $dbh->disconnect;
 369
 370 }
 371
 372
 373
 374 sub dbsources_unused {
 375   my ($self, $form, $memfile) = @_;
 376
 377   my @dbexcl = ();
 378   my @dbsources = ();
 379
 380   $form->error('File locked!') if (-f "${memfile}.LCK");
 381
 382   # open members file
 383   open(FH, "$memfile") or $form->error("$memfile : $!");
 384
 385   while (<FH>) {
 386     if (/^dbname=/) {
 387       my ($null,$item) = split /=/;
 388       push @dbexcl, $item;
 389     }
 390   }
 391
 392   close FH;
 393
 394   $form->{only_acc_db} = 1;
 395   my @db = &dbsources("", $form);
 396
 397   push @dbexcl, $form->{dbdefault};
 398
 399   foreach $item (@db) {
 400     unless (grep /$item$/, @dbexcl) {
 401       push @dbsources, $item;
 402     }
 403   }
 404
 405   return @dbsources;
 406
 407 }
 408
 409
 410 sub dbneedsupdate {
 411   my ($self, $form) = @_;
 412
 413   my %dbsources = ();
 414   my $query;
 415
 416   $form->{sid} = $form->{dbdefault};
 417   &dbconnect_vars($form, $form->{dbdefault});
 418
 419   my $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) or $form->dberror;
 420
 421   if ($form->{dbdriver} eq 'Pg') {
 422
 423     $query = qq|SELECT d.datname FROM pg_database d, pg_user u
 424                 WHERE d.datdba = u.usesysid
 425                 AND u.usename = '$form->{dbuser}'|;
 426     my $sth = $dbh->prepare($query);
 427     $sth->execute || $form->dberror($query);
 428
 429     while (my ($db) = $sth->fetchrow_array) {
 430
 431       next if ($db =~ /^template/);
 432
 433       &dbconnect_vars($form, $db);
 434
 435       my $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) or $form->dberror;
 436
 437       $query = qq|SELECT tablename FROM pg_tables
 438                   WHERE tablename = 'defaults'|;
 439       my $sth = $dbh->prepare($query);
 440       $sth->execute || $form->dberror($query);
 441
 442       if ($sth->fetchrow_array) {
 443         $query = qq|SELECT version FROM defaults|;
 444         my $sth = $dbh->prepare($query);
 445         $sth->execute;
 446
 447         if (my ($version) = $sth->fetchrow_array) {
 448           $dbsources{$db} = $version;
 449         }
 450         $sth->finish;
 451       }
 452       $sth->finish;
 453       $dbh->disconnect;
 454     }
 455     $sth->finish;
 456   }
 457
 458
 459   if ($form->{dbdriver} eq 'Oracle') {
 460     $query = qq|SELECT owner FROM dba_objects
 461                 WHERE object_name = 'DEFAULTS'
 462                 AND object_type = 'TABLE'|;
 463
 464     $sth = $dbh->prepare($query);
 465     $sth->execute || $form->dberror($query);
 466
 467     while (my ($db) = $sth->fetchrow_array) {
 468
 469       $form->{dbuser} = $db;
 470       &dbconnect_vars($form, $db);
 471
 472       my $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) or $form->dberror;
 473
 474       $query = qq|SELECT version FROM defaults|;
 475       my $sth = $dbh->prepare($query);
 476       $sth->execute;
 477
 478       if (my ($version) = $sth->fetchrow_array) {
 479         $dbsources{$db} = $version;
 480       }
 481       $sth->finish;
 482       $dbh->disconnect;
 483     }
 484     $sth->finish;
 485   }
 486
 487   $dbh->disconnect;
 488
 489   %dbsources;
 490
 491 }
 492
 493
 494 sub dbupdate {
 495   my ($self, $form) = @_;
 496
 497   $form->{sid} = $form->{dbdefault};
 498
 499   my @upgradescripts = ();
 500   my $query;
 501
 502   if ($form->{dbupdate}) {
 503     # read update scripts into memory
 504     opendir SQLDIR, "sql/." or $form-error($!);
 505     @upgradescripts = sort grep /$form->{dbdriver}-upgrade-.*?\.sql/, readdir SQLDIR;
 506     closedir SQLDIR;
 507   }
 508
 509
 510   foreach my $db (split / /, $form->{dbupdate}) {
 511
 512     next unless $form->{$db};
 513
 514     # strip db from dataset
 515     $db =~ s/^db//;
 516     &dbconnect_vars($form, $db);
 517
 518     my $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) or $form->dberror;
 519
 520     # check version
 521     $query = qq|SELECT version FROM defaults|;
 522     my $sth = $dbh->prepare($query);
 523     # no error check, let it fall through
 524     $sth->execute;
 525
 526     my $version = $sth->fetchrow_array;
 527     $sth->finish;
 528
 529     next unless $version;
 530
 531     foreach my $upgradescript (@upgradescripts) {
 532       my $a = $upgradescript;
 533       $a =~ s/(^$form->{dbdriver}-upgrade-|\.sql$)//g;
 534
 535       my ($mindb, $maxdb) = split /-/, $a;
 536
 537       next if ($version ge $maxdb);
 538
 539       # if there is no upgrade script exit
 540       last if ($version lt $mindb);
 541
 542       # apply upgrade
 543       $self->processquery($form, $dbh, "sql/$upgradescript");
 544
 545       $version = $maxdb;
 546
 547     }
 548
 549     $dbh->disconnect;
 550
 551   }
 552 }
 553
 554
 555
 556 sub create_config {
 557   my ($self, $filename) = @_;
 558
 559
 560   @config = &config_vars;
 561
 562   open(CONF, ">$filename") or $self->error("$filename : $!");
 563
 564   # create the config file
 565   print CONF qq|# configuration file for $self->{login}
 566
 567 \%myconfig = (
 568 |;
 569
 570   foreach $key (sort @config) {
 571     $self->{$key} =~ s/'/\\'/g;
 572     print CONF qq|  $key => '$self->{$key}',\n|;
 573   }
 574
 575
 576   print CONF qq|);\n\n|;
 577
 578   close CONF;
 579
 580 }
 581
 582
 583 sub save_member {
 584   my ($self, $memberfile, $userspath) = @_;
 585
 586   my $newmember = 1;
 587
 588   # format dbconnect and dboptions string
 589   map { $self->{$_} = lc $self->{$_} } qw(dbname host);
 590   &dbconnect_vars($self, $self->{dbname});
 591
 592   $self->error('File locked!') if (-f "${memberfile}.LCK");
 593   open(FH, ">${memberfile}.LCK") or $self->error("${memberfile}.LCK : $!");
 594   close(FH);
 595
 596   open(CONF, "+<$memberfile") or $self->error("$memberfile : $!");
 597
 598   @config = <CONF>;
 599
 600   seek(CONF, 0, 0);
 601   truncate(CONF, 0);
 602
 603   while ($line = shift @config) {
 604     if ($line =~ /^\[$self->{login}\]/) {
 605       $newmember = 0;
 606       last;
 607     }
 608     print CONF $line;
 609   }
 610
 611   # remove everything up to next login or EOF
 612   while ($line = shift @config) {
 613     last if ($line =~ /^\[/);
 614   }
 615
 616   # this one is either the next login or EOF
 617   print CONF $line;
 618
 619   while ($line = shift @config) {
 620     print CONF $line;
 621   }
 622
 623   print CONF qq|[$self->{login}]\n|;
 624
 625   if ((($self->{dbpasswd} ne $self->{old_dbpasswd}) || $newmember) && $self->{root}) {
 626     $self->{dbpasswd} = pack 'u', $self->{dbpasswd};
 627     chop $self->{dbpasswd};
 628   }
 629
 630   if ($self->{password} ne $self->{old_password}) {
 631     $self->{password} = crypt $self->{password}, substr($self->{login}, 0, 2) if $self->{password};
 632   }
 633
 634   if ($self->{'root login'}) {
 635     @config = ("password");
 636   } else {
 637     @config = &config_vars;
 638   }
 639
 640   # replace \r\n with \n
 641   $self->{address} =~ s/\r\n/\\n/g if $self->{address};
 642   $self->{signature} =~ s/\r\n/\\n/g if $self->{signature};
 643
 644   foreach $key (sort @config) {
 645     print CONF qq|$key=$self->{$key}\n|;
 646   }
 647
 648   print CONF "\n";
 649   close CONF;
 650   unlink "${memberfile}.LCK";
 651
 652   # create conf file
 653   $self->create_config("$userspath/$self->{login}.conf") unless $self->{'root login'};
 654
 655 }
 656
 657
 658 sub config_vars {
 659
 660   my @conf = qw(acs address admin businessnumber charset company countrycode
 661              currency dateformat dbconnect dbdriver dbhost dbport dboptions
 662              dbname dbuser dbpasswd email fax name numberformat password
 663              printer sid shippingpoint signature stylesheet tel templates
 664              vclimit);
 665
 666   @conf;
 667
 668 }
 669
 670
 671 sub error {
 672   my ($self, $msg) = @_;
 673
 674   if ($ENV{HTTP_USER_AGENT}) {
 675     print qq|Content-Type: text/html
 676
 677 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN">
 678
 679 <body bgcolor=ffffff>
 680
 681 <h2><font color=red>Error!</font></h2>
 682 <p><b>$msg</b>|;
 683
 684   }
 685
 686   die "Error: $msg\n";
 687
 688 }
 689
 690
 691 1;
 692