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

   1 #=====================================================================
   2 # SQL-Ledger Accounting
   3 # Copyright (C) 1998-2003
   4 #
   5 #  Author: Dieter Simader
   6 #   Email: dsimader@sql-ledger.org
   7 #     Web: http://www.sql-ledger.org
   8 #
   9 # Contributors: Thomas Bayen <bayen@gmx.de>
  10 #               Antti Kaihola <akaihola@siba.fi>
  11 #               Moritz Bunkus (tex code)
  12 #
  13 # This program is free software; you can redistribute it and/or modify
  14 # it under the terms of the GNU General Public License as published by
  15 # the Free Software Foundation; either version 2 of the License, or
  16 # (at your option) any later version.
  17 #
  18 # This program is distributed in the hope that it will be useful,
  19 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 # GNU General Public License for more details.
  22 # You should have received a copy of the GNU General Public License
  23 # along with this program; if not, write to the Free Software
  24 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  25 #======================================================================
  26 # Utilities for parsing forms
  27 # and supporting routines for linking account numbers
  28 # used in AR, AP and IS, IR modules
  29 #
  30 #======================================================================
  31
  32 package Form;
  33
  34
  35 sub new {
  36   my $type = shift;
  37
  38   my $self = {};
  39
  40   read(STDIN, $_, $ENV{CONTENT_LENGTH});
  41
  42   if ($ENV{QUERY_STRING}) {
  43     $_ = $ENV{QUERY_STRING};
  44   }
  45
  46   if ($ARGV[0]) {
  47     $_ = $ARGV[0];
  48   }
  49
  50   foreach $item (split(/&/)) {
  51     ($key, $value) = split(/=/, $item);
  52     $self->{$key} = &unescape("",$value);
  53   }
  54
  55   $self->{action} = lc $self->{action};
  56   $self->{action} =~ s/( |-|,)/_/g;
  57
  58   $self->{version} = "2.0.8";
  59   $self->{dbversion} = "2.0.8";
  60
  61   bless $self, $type;
  62
  63 }
  64
  65
  66 sub debug {
  67   my ($self) = @_;
  68
  69   print "\n";
  70
  71   map { print "$_ = $self->{$_}\n" } (sort keys %{$self});
  72
  73 }
  74
  75
  76 sub escape {
  77   my ($self, $str, $beenthere) = @_;
  78
  79   # for Apache 2 we escape strings twice
  80   if (($ENV{SERVER_SOFTWARE} =~ /Apache\/2/) && !$beenthere) {
  81     $str = $self->escape($str, 1);
  82   }
  83
  84   $str =~ s/([^a-zA-Z0-9_.-])/sprintf("%%%02x", ord($1))/ge;
  85   $str;
  86
  87 }
  88
  89
  90 sub unescape {
  91   my ($self, $str) = @_;
  92
  93   $str =~ tr/+/ /;
  94   $str =~ s/\\$//;
  95
  96   $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
  97
  98   $str;
  99
 100 }
 101
 102
 103 sub error {
 104   my ($self, $msg) = @_;
 105
 106   if ($ENV{HTTP_USER_AGENT}) {
 107     $msg =~ s/\n/<br>/g;
 108
 109     print qq|Content-Type: text/html
 110
 111     <body bgcolor=ffffff>
 112
 113     <h2><font color=red>Error!</font></h2>
 114
 115     <p><b>$msg</b>
 116
 117     </body>
 118     </html>
 119     |;
 120
 121     die "Error: $msg\n";
 122
 123   } else {
 124
 125     if ($self->{error_function}) {
 126       &{ $self->{error_function} }($msg);
 127     } else {
 128       die "Error: $msg\n";
 129     }
 130   }
 131
 132 }
 133
 134
 135
 136 sub info {
 137   my ($self, $msg) = @_;
 138
 139   if ($ENV{HTTP_USER_AGENT}) {
 140     $msg =~ s/\n/<br>/g;
 141
 142     if (!$self->{header}) {
 143       $self->header;
 144       print qq|
 145       <body>|;
 146     }
 147
 148     print qq|
 149
 150     <p><b>$msg</b>
 151     |;
 152
 153   } else {
 154
 155     if ($self->{info_function}) {
 156       &{ $self->{info_function} }($msg);
 157     } else {
 158       print "$msg\n";
 159     }
 160   }
 161
 162 }
 163
 164
 165 sub numtextrows {
 166   my ($self, $str, $cols, $maxrows) = @_;
 167
 168   my $rows;
 169
 170   map { $rows += int ((length $_)/$cols) + 1 } (split /\r/, $str);
 171
 172   $rows = $maxrows if (defined $maxrows && ($rows > $maxrows));
 173
 174   $rows;
 175
 176 }
 177
 178
 179 sub dberror {
 180   my ($self, $msg) = @_;
 181
 182   $self->error("$msg\n".$DBI::errstr);
 183
 184 }
 185
 186
 187 sub isblank {
 188   my ($self, $name, $msg) = @_;
 189
 190   if ($self->{$name} =~ /^\s*$/) {
 191     $self->error($msg);
 192   }
 193 }
 194
 195
 196 sub header {
 197   my ($self) = @_;
 198
 199   my ($nocache, $stylesheet, $charset);
 200
 201   # use expire tag to prevent caching
 202 #  $nocache = qq|<META HTTP-EQUIV="Expires" CONTENT="Tue, 01 Jan 1980 1:00:00 GMT">
 203 #  <META HTTP-EQUIV="Pragma" CONTENT="no-cache">
 204 #|;
 205
 206   if ($self->{stylesheet} && (-f "css/$self->{stylesheet}")) {
 207     $stylesheet = qq|<LINK REL="stylesheet" HREF="css/$self->{stylesheet}" TYPE="text/css" TITLE="SQL-Ledger style sheet">
 208 |;
 209   }
 210
 211   if ($self->{charset}) {
 212     $charset = qq|<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=$self->{charset}">
 213 |;
 214   }
 215
 216   $self->{titlebar} = ($self->{title}) ? "$self->{title} - $self->{titlebar}" : $self->{titlebar};
 217
 218   print qq|Content-Type: text/html
 219
 220 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN">
 221 <head>
 222   <title>$self->{titlebar}</title>
 223   $nocache
 224   $stylesheet
 225   $charset
 226 </head>
 227
 228 |;
 229
 230 }
 231
 232
 233 sub redirect {
 234   my ($self, $msg) = @_;
 235
 236   if ($self->{callback}) {
 237
 238     ($script, $argv) = split(/\?/, $self->{callback});
 239
 240     exec ("perl", "$script", $argv);
 241
 242   } else {
 243
 244     if ($ENV{HTTP_USER_AGENT}) {
 245       $msg =~ s/\n/<br>/g;
 246
 247       print qq|Content-Type: text/html
 248
 249 <body bgcolor=ffffff>
 250
 251 <h2>$msg</h2>
 252
 253 </body>
 254 </html>
 255 |;
 256
 257     } else {
 258       print "$msg\n";
 259     }
 260
 261     exit;
 262
 263   }
 264
 265 }
 266
 267
 268 sub sort_columns {
 269   my ($self, @columns) = @_;
 270
 271   @columns = grep !/^$self->{sort}$/, @columns;
 272   splice @columns, 0, 0, $self->{sort};
 273
 274   @columns;
 275
 276 }
 277
 278
 279 sub format_amount {
 280   my ($self, $myconfig, $amount, $places, $dash) = @_;
 281
 282   if ($places =~ /\d/) {
 283     $amount = $self->round_amount($amount, $places);
 284   }
 285
 286   # is the amount negative
 287   my $negative = ($amount < 0);
 288
 289   if ($amount != 0) {
 290     if ($myconfig->{numberformat} && ($myconfig->{numberformat} ne '1000.00')) {
 291       my ($whole, $dec) = split /\./, "$amount";
 292       $whole =~ s/-//;
 293       $amount = join '', reverse split //, $whole;
 294
 295       if ($myconfig->{numberformat} eq '1,000.00') {
 296         $amount =~ s/\d{3,}?/$&,/g;
 297         $amount =~ s/,$//;
 298         $amount = join '', reverse split //, $amount;
 299         $amount .= "\.$dec" if ($dec ne "");
 300       }
 301
 302       if ($myconfig->{numberformat} eq '1.000,00') {
 303         $amount =~ s/\d{3,}?/$&./g;
 304         $amount =~ s/\.$//;
 305         $amount = join '', reverse split //, $amount;
 306         $amount .= ",$dec" if ($dec ne "");
 307       }
 308
 309       if ($myconfig->{numberformat} eq '1000,00') {
 310         $amount = "$whole";
 311         $amount .= ",$dec" if ($dec ne "");
 312       }
 313
 314       if ($dash =~ /-/) {
 315         $amount = ($negative) ? "($amount)" : "$amount";
 316       } elsif ($dash =~ /DRCR/) {
 317         $amount = ($negative) ? "$amount DR" : "$amount CR";
 318       } else {
 319         $amount = ($negative) ? "-$amount" : "$amount";
 320       }
 321     }
 322   } else {
 323     if ($dash eq "0" && $places) {
 324       if ($myconfig->{numberformat} eq '1.000,00') {
 325         $amount = "0".","."0" x $places;
 326       } else {
 327         $amount = "0"."."."0" x $places;
 328       }
 329     } else {
 330       $amount = ($dash ne "") ? "$dash" : "";
 331     }
 332   }
 333
 334   $amount;
 335
 336 }
 337
 338
 339 sub parse_amount {
 340   my ($self, $myconfig, $amount) = @_;
 341
 342   if (($myconfig->{numberformat} eq '1.000,00') ||
 343       ($myconfig->{numberformat} eq '1000,00')) {
 344     $amount =~ s/\.//g;
 345     $amount =~ s/,/\./;
 346   }
 347
 348   $amount =~ s/,//g;
 349
 350   return ($amount * 1);
 351
 352 }
 353
 354
 355 sub round_amount {
 356   my ($self, $amount, $places) = @_;
 357
 358 #  $places = 3 if $places == 2;
 359
 360   if (($places * 1) >= 0) {
 361     # compensate for perl behaviour, add 1/10^$places+3
 362     sprintf("%.${places}f", $amount + (1 / (10 ** ($places + 3))) * (($amount > 0) ? 1 : -1));
 363   } else {
 364     $places *= -1;
 365     sprintf("%.f", $amount / (10 ** $places) + (($amount > 0) ? 0.1 : -0.1)) * (10 ** $places);
 366   }
 367
 368 }
 369
 370
 371 sub parse_template {
 372   my ($self, $myconfig, $userspath) = @_;
 373
 374   # { Moritz Bunkus
 375   # Some variables used for page breaks
 376   my ($chars_per_line, $lines_on_first_page, $lines_on_second_page) = (0, 0, 0);
 377   my ($current_page, $current_line) = (1, 1);
 378   my $pagebreak = "";
 379   my $sum = 0;
 380   # } Moritz Bunkus
 381
 382   open(IN, "$self->{templates}/$self->{IN}") or $self->error("$self->{IN} : $!");
 383
 384   @_ = <IN>;
 385   close(IN);
 386
 387   $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
 388
 389   # OUT is used for the media, screen, printer, email
 390   # for postscript we store a copy in a temporary file
 391   my $fileid = time;
 392   $self->{tmpfile} = "$userspath/${fileid}.$self->{IN}";
 393   if ($self->{format} =~ /(postscript|pdf)/ || $self->{media} eq 'email') {
 394     $out = $self->{OUT};
 395     $self->{OUT} = ">$self->{tmpfile}";
 396   }
 397
 398
 399   if ($self->{OUT}) {
 400     open(OUT, "$self->{OUT}") or $self->error("$self->{OUT} : $!");
 401   } else {
 402     open(OUT, ">-") or $self->error("STDOUT : $!");
 403     $self->header;
 404   }
 405
 406
 407   # first we generate a tmpfile
 408   # read file and replace <%variable%>
 409   while ($_ = shift) {
 410
 411     $par = "";
 412     $var = $_;
 413
 414
 415     # { Moritz Bunkus
 416     # detect pagebreak block and its parameters
 417     if (/<%pagebreak ([0-9]+) ([0-9]+) ([0-9]+)%>/) {
 418       $chars_per_line = $1;
 419       $lines_on_first_page = $2;
 420       $lines_on_second_page = $3;
 421
 422       while ($_ = shift) {
 423         last if (/<\%end pagebreak%>/);
 424         $pagebreak .= $_;
 425       }
 426     }
 427     # } Moritz Bunkus
 428
 429
 430     if (/<%foreach /) {
 431
 432       # this one we need for the count
 433       chomp $var;
 434       $var =~ s/<%foreach (.+?)%>/$1/;
 435       while ($_ = shift) {
 436         last if (/<%end /);
 437
 438         # store line in $par
 439         $par .= $_;
 440       }
 441
 442       # display contents of $self->{number}[] array
 443       for $i (0 .. $#{ $self->{$var} }) {
 444
 445         # { Moritz Bunkus
 446         # Try to detect whether a manual page break is necessary
 447         # but only if there was a <%pagebreak ...%> block before
 448
 449         if ($chars_per_line) {
 450           my $lines = int(length($self->{"description"}[$i]) / $chars_per_line + 0.95);
 451           my $lpp;
 452
 453           if ($current_page == 1) {
 454             $lpp = $lines_on_first_page;
 455           } else {
 456             $lpp = $lines_on_second_page;
 457           }
 458
 459           # Yes we need a manual page break
 460           if (($current_line + $lines) > $lpp) {
 461             my $pb = $pagebreak;
 462
 463             # replace the special variables <%sumcarriedforward%>
 464             # and <%lastpage%>
 465
 466             my $psum = $self->format_amount($myconfig, $sum, 2);
 467             $pb =~ s/<%sumcarriedforward%>/$psum/g;
 468             $pb =~ s/<%lastpage%>/$current_page/g;
 469
 470             # only "normal" variables are supported here
 471             # (no <%if, no <%foreach, no <%include)
 472
 473             $pb =~ s/<%(.+?)%>/$self->{$1}/g;
 474
 475             # page break block is ready to rock
 476             print(OUT $pb);
 477             $current_page++;
 478             $current_line = 1;
 479           }
 480           $current_line += $lines;
 481         }
 482         $sum += $self->parse_amount($myconfig, $self->{"linetotal"}[$i]);
 483         # } Moritz Bunkus
 484
 485
 486         # don't parse par, we need it for each line
 487         $_ = $par;
 488         s/<%(.+?)%>/$self->{$1}[$i]/mg;
 489         print OUT;
 490       }
 491       next;
 492     }
 493
 494     # if not comes before if!
 495     if (/<%if not /) {
 496       # check if it is not set and display
 497       chop;
 498       s/<%if not (.+?)%>/$1/;
 499
 500       unless ($self->{$_}) {
 501         while ($_ = shift) {
 502           last if (/<%end /);
 503
 504           # store line in $par
 505           $par .= $_;
 506         }
 507
 508         $_ = $par;
 509
 510       } else {
 511         while ($_ = shift) {
 512           last if (/<%end /);
 513         }
 514         next;
 515       }
 516     }
 517
 518     if (/<%if /) {
 519       # check if it is set and display
 520       chop;
 521       s/<%if (.+?)%>/$1/;
 522
 523       if ($self->{$_}) {
 524         while ($_ = shift) {
 525           last if (/<%end /);
 526
 527           # store line in $par
 528           $par .= $_;
 529         }
 530
 531         $_ = $par;
 532
 533       } else {
 534         while ($_ = shift) {
 535           last if (/<%end /);
 536         }
 537         next;
 538       }
 539     }
 540
 541     # check for <%include filename%>
 542     if (/<%include /) {
 543
 544       # get the filename
 545       chomp $var;
 546       $var =~ s/<%include (.+?)%>/$1/;
 547
 548       # mangle filename if someone tries to be cute
 549       $var =~ s/\///g;
 550
 551       # prevent the infinite loop!
 552       next if ($self->{"$var"});
 553
 554       open(INC, "$self->{templates}/$var") or $self->error($self->cleanup."$self->{templates}/$var : $!");
 555       unshift(@_, <INC>);
 556       close(INC);
 557
 558       $self->{"$var"} = 1;
 559
 560       next;
 561     }
 562
 563     s/<%(.+?)%>/$self->{$1}/g;
 564     print OUT;
 565   }
 566
 567   close(OUT);
 568
 569
 570   # { Moritz Bunkus
 571   # Convert the tex file to postscript
 572   if ($self->{format} =~ /(postscript|pdf)/) {
 573
 574     use Cwd;
 575     $self->{cwd} = cwd();
 576     chdir("$userspath") or $self->error($self->cleanup."chdir : $!");
 577
 578     $self->{tmpfile} =~ s/$userspath\///g;
 579
 580     # DS. added screen and email option in addition to printer
 581     # screen
 582     if ($self->{format} eq 'postscript') {
 583       system("latex --interaction=nonstopmode $self->{tmpfile} > $self->{tmpfile}.err");
 584       $self->error($self->cleanup) if ($?);
 585
 586       $self->{tmpfile} =~ s/tex$/dvi/;
 587
 588       system("dvips $self->{tmpfile} -o -q > /dev/null");
 589       $self->error($self->cleanup."dvips : $!") if ($?);
 590       $self->{tmpfile} =~ s/dvi$/ps/;
 591     }
 592     if ($self->{format} eq 'pdf') {
 593       system("pdflatex --interaction=nonstopmode $self->{tmpfile} > $self->{tmpfile}.err");
 594       $self->error($self->cleanup) if ($?);
 595       $self->{tmpfile} =~ s/tex$/pdf/;
 596     }
 597
 598   }
 599
 600   if ($self->{format} =~ /(postscript|pdf)/ || $self->{media} eq 'email') {
 601
 602     if ($self->{media} eq 'email') {
 603
 604       use SL::Mailer;
 605
 606       my $mail = new Mailer;
 607
 608       $self->{email} =~ s/,/>,</g;
 609
 610       map { $mail->{$_} = $self->{$_} } qw(cc bcc subject message version format charset);
 611       $mail->{to} = qq|"$self->{name}" <$self->{email}>|;
 612       $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
 613       $mail->{fileid} = "$fileid.";
 614
 615       # if we send html or plain text inline
 616       if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
 617         $mail->{contenttype} = "text/html";
 618
 619         $mail->{message} =~ s/\r\n/<br>\n/g;
 620         $myconfig->{signature} =~ s/\\n/<br>\n/g;
 621         $mail->{message} .= "<br>\n--<br>\n$myconfig->{signature}\n<br>";
 622
 623         open(IN, $self->{tmpfile}) or $self->error($self->cleanup."$self->{tmpfile} : $!");
 624         while (<IN>) {
 625           $mail->{message} .= $_;
 626         }
 627
 628         close(IN);
 629
 630       } else {
 631
 632         @{ $mail->{attachments} } = ($self->{tmpfile});
 633
 634         $myconfig->{signature} =~ s/\\n/\r\n/g;
 635         $mail->{message} .= "\r\n--\r\n$myconfig->{signature}";
 636
 637       }
 638
 639       my $err = $mail->send($out);
 640       $self->error($self->cleanup."$err") if ($err);
 641
 642     } else {
 643
 644       $self->{OUT} = $out;
 645       open(IN, $self->{tmpfile}) or $self->error($self->cleanup."$self->{tmpfile} : $!");
 646
 647       $self->{copies} = 1 unless $self->{media} eq 'printer';
 648
 649       for my $i (1 .. $self->{copies}) {
 650
 651         if ($self->{OUT}) {
 652           open(OUT, $self->{OUT}) or $self->error($self->cleanup."$self->{OUT} : $!");
 653         } else {
 654           open(OUT, ">-") or $self->error($self->cleanup."$!: STDOUT");
 655
 656           # launch application
 657           print qq|Content-Type: application/$self->{format}; name="$self->{tmpfile}"
 658   Content-Disposition: filename="$self->{tmpfile}"
 659
 660   |;
 661         }
 662
 663         while (<IN>) {
 664           print OUT $_;
 665         }
 666         close(OUT);
 667         seek IN, 0, 0;
 668       }
 669
 670       close(IN);
 671     }
 672
 673     $self->cleanup;
 674
 675   }
 676   # } Moritz Bunkus
 677
 678 }
 679
 680
 681 sub cleanup {
 682   my $self = shift;
 683
 684   my @err = ();
 685   if (-f "$self->{tmpfile}.err") {
 686     open(FH, "$self->{tmpfile}.err");
 687     @err = <FH>;
 688     close(FH);
 689   }
 690
 691   if ($self->{tmpfile}) {
 692     # strip extension
 693     $self->{tmpfile} =~ s/\.\w+$//g;
 694     my $tmpfile = $self->{tmpfile};
 695     unlink(<$tmpfile.*>);
 696   }
 697
 698
 699   chdir("$self->{cwd}");
 700
 701   "@err";
 702
 703 }
 704
 705
 706 sub format_string {
 707   my ($self, @fields) = @_;
 708
 709   my $format = $self->{format};
 710   if ($self->{format} =~ /(postscript|pdf)/) {
 711     $format = 'tex';
 712   }
 713
 714   my %replace = ( 'order' => { 'html' => [ quotemeta('\n'), '\r' ],
 715                                'tex'  => [ '&', quotemeta('\n'), '\r',
 716                                            '\$', '%', '_', '#', quotemeta('^'),
 717                                            '{', '}', '<', '>', '£' ] },
 718                   'html' => {
 719                 quotemeta('\n') => '<br>', '\r' => '<br>'
 720                             },
 721                    'tex' => {
 722                 '&' => '\&', '\$' => '\$', '%' => '\%', '_' => '\_',
 723                 '#' => '\#', quotemeta('^') => '\^\\', '{' => '\{', '}' => '\}',
 724                 '<' => '$<$', '>' => '$>$',
 725                 quotemeta('\n') => '\newline ', '\r' => '\newline ',
 726                 '£' => '\pounds ',
 727                             }
 728                 );
 729
 730   foreach my $key (@{ $replace{order}{$format} }) {
 731     map { $self->{$_} =~ s/$key/$replace{$format}{$key}/g; } @fields;
 732   }
 733
 734 }
 735
 736
 737 sub datetonum {
 738   my ($self, $date, $myconfig) = @_;
 739
 740   if ($date) {
 741     # get separator
 742     my $spc = $myconfig->{dateformat};
 743     $spc =~ s/\w//g;
 744     $spc = substr($spc, 1, 1);
 745
 746     if ($spc eq '.') {
 747       $spc = '\.';
 748     }
 749     if ($spc eq '/') {
 750       $spc = '\/';
 751     }
 752
 753     if ($myconfig->{dateformat} =~ /^yy/) {
 754       ($yy, $mm, $dd) = split /$spc/, $date;
 755     }
 756     if ($myconfig->{dateformat} =~ /^mm/) {
 757       ($mm, $dd, $yy) = split /$spc/, $date;
 758     }
 759     if ($myconfig->{dateformat} =~ /^dd/) {
 760       ($dd, $mm, $yy) = split /$spc/, $date;
 761     }
 762
 763     $dd *= 1;
 764     $mm *= 1;
 765     $yy = ($yy < 70) ? $yy + 2000 : $yy;
 766     $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
 767
 768     $dd = "0$dd" if ($dd < 10);
 769     $mm = "0$mm" if ($mm < 10);
 770
 771     $date = "$yy$mm$dd";
 772   }
 773
 774   $date;
 775
 776 }
 777
 778
 779
 780 # Database routines used throughout
 781
 782 sub dbconnect {
 783   my ($self, $myconfig) = @_;
 784
 785   # connect to database
 786   my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}) or $self->dberror;
 787
 788   # set db options
 789   if ($myconfig->{dboptions}) {
 790     $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
 791   }
 792
 793   $dbh;
 794
 795 }
 796
 797
 798 sub dbconnect_noauto {
 799   my ($self, $myconfig) = @_;
 800
 801   # connect to database
 802   $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, {AutoCommit => 0}) or $self->dberror;
 803
 804   # set db options
 805   if ($myconfig->{dboptions}) {
 806     $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
 807   }
 808
 809   $dbh;
 810
 811 }
 812
 813
 814 sub update_balance {
 815   my ($self, $dbh, $table, $field, $where, $value) = @_;
 816
 817   # if we have a value, go do it
 818   if ($value != 0) {
 819     # retrieve balance from table
 820     my $query = "SELECT $field FROM $table WHERE $where";
 821     my $sth = $dbh->prepare($query);
 822
 823     $sth->execute || $self->dberror($query);
 824     my ($balance) = $sth->fetchrow_array;
 825     $sth->finish;
 826
 827     $balance += $value;
 828     # update balance
 829     $query = "UPDATE $table SET $field = $balance WHERE $where";
 830     $dbh->do($query) || $self->dberror($query);
 831   }
 832 }
 833
 834
 835
 836 sub update_exchangerate {
 837   my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
 838
 839   # some sanity check for currency
 840   return if ($curr eq '');
 841
 842   my $query = qq|SELECT curr FROM exchangerate
 843                  WHERE curr = '$curr'
 844                  AND transdate = '$transdate'|;
 845   my $sth = $dbh->prepare($query);
 846   $sth->execute || $self->dberror($query);
 847
 848   my $set;
 849   if ($buy != 0 && $sell != 0) {
 850     $set = "buy = $buy, sell = $sell";
 851   } elsif ($buy != 0) {
 852     $set = "buy = $buy";
 853   } elsif ($sell != 0) {
 854     $set = "sell = $sell";
 855   }
 856
 857   if ($sth->fetchrow_array) {
 858     $query = qq|UPDATE exchangerate
 859                 SET $set
 860                 WHERE curr = '$curr'
 861                 AND transdate = '$transdate'|;
 862   } else {
 863     $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
 864                 VALUES ('$curr', $buy, $sell, '$transdate')|;
 865   }
 866   $sth->finish;
 867   $dbh->do($query) || $self->dberror($query);
 868
 869 }
 870
 871
 872 sub get_exchangerate {
 873   my ($self, $dbh, $curr, $transdate, $fld) = @_;
 874
 875   my $query = qq|SELECT $fld FROM exchangerate
 876                  WHERE curr = '$curr'
 877                  AND transdate = '$transdate'|;
 878   my $sth = $dbh->prepare($query);
 879   $sth->execute || $self->dberror($query);
 880
 881   my ($exchangerate) = $sth->fetchrow_array;
 882   $sth->finish;
 883
 884   $exchangerate;
 885
 886 }
 887
 888
 889 sub delete_exchangerate {
 890   my ($self, $dbh) = @_;
 891
 892   my @transdate = ();
 893   my $transdate;
 894
 895   my $query = qq|SELECT DISTINCT transdate
 896                  FROM acc_trans
 897                  WHERE trans_id = $self->{id}|;
 898   my $sth = $dbh->prepare($query);
 899   $sth->execute || $self->dberror($query);
 900
 901   while ($transdate = $sth->fetchrow_array) {
 902     push @transdate, $transdate;
 903   }
 904   $sth->finish;
 905
 906   $query = qq|SELECT transdate FROM acc_trans
 907               WHERE ar.id = trans_id
 908               AND ar.curr = '$self->{currency}'
 909               AND transdate IN
 910                   (SELECT transdate FROM acc_trans
 911                   WHERE trans_id = $self->{id})
 912               AND trans_id != $self->{id}
 913         UNION SELECT transdate FROM acc_trans
 914               WHERE ap.id = trans_id
 915               AND ap.curr = '$self->{currency}'
 916               AND transdate IN
 917                   (SELECT transdate FROM acc_trans
 918                   WHERE trans_id = $self->{id})
 919               AND trans_id != $self->{id}
 920         UNION SELECT transdate FROM oe
 921                 WHERE oe.curr = '$self->{currency}'
 922                 AND transdate IN
 923                     (SELECT transdate FROM acc_trans
 924                     WHERE trans_id = $self->{id})|;
 925   $sth = $dbh->prepare($query);
 926   $sth->execute || $self->dberror($query);
 927
 928   while ($transdate = $sth->fetchrow_array) {
 929     @transdate = grep !/^$transdate$/, @transdate;
 930   }
 931   $sth->finish;
 932
 933   foreach $transdate (@transdate) {
 934     $query = qq|DELETE FROM exchangerate
 935                 WHERE curr = '$self->{currency}'
 936                 AND transdate = '$transdate'|;
 937     $dbh->do($query) || $self->dberror($query);
 938   }
 939
 940 }
 941
 942
 943 sub check_exchangerate {
 944   my ($self, $myconfig, $currency, $transdate, $fld) = @_;
 945
 946   return "" unless $transdate;
 947
 948   my $dbh = $self->dbconnect($myconfig);
 949
 950   my $query = qq|SELECT $fld FROM exchangerate
 951                  WHERE curr = '$currency'
 952                  AND transdate = '$transdate'|;
 953   my $sth = $dbh->prepare($query);
 954   $sth->execute || $self->dberror($query);
 955
 956   my ($exchangerate) = $sth->fetchrow_array;
 957   $sth->finish;
 958   $dbh->disconnect;
 959
 960   $exchangerate;
 961
 962 }
 963
 964
 965 sub add_shipto {
 966   my ($self, $dbh, $id) = @_;
 967
 968   my $shipto;
 969   foreach my $item (qw(name addr1 addr2 addr3 addr4 contact phone fax email)) {
 970     if ($self->{"shipto$item"}) {
 971       $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
 972     }
 973     $self->{"shipto$item"} =~ s/'/''/g;
 974   }
 975
 976   if ($shipto) {
 977     my $query = qq|INSERT INTO shipto (trans_id, shiptoname, shiptoaddr1,
 978                    shiptoaddr2, shiptoaddr3, shiptoaddr4, shiptocontact,
 979                    shiptophone, shiptofax, shiptoemail) VALUES ($id,
 980                    '$self->{shiptoname}', '$self->{shiptoaddr1}',
 981                    '$self->{shiptoaddr2}', '$self->{shiptoaddr3}',
 982                    '$self->{shiptoaddr4}', '$self->{shiptocontact}',
 983                    '$self->{shiptophone}', '$self->{shiptofax}',
 984                    '$self->{shiptoemail}')|;
 985     $dbh->do($query) || $self->dberror($query);
 986   }
 987
 988 }
 989
 990
 991 sub get_employee {
 992   my ($self, $dbh) = @_;
 993
 994   my $query = qq|SELECT name FROM employee
 995                  WHERE login = '$self->{login}'|;
 996   my $sth = $dbh->prepare($query);
 997   $sth->execute || $self->dberror($query);
 998
 999   ($self->{employee}) = $sth->fetchrow_array;
1000   $sth->finish;
1001
1002 }
1003
1004
1005 # this sub gets the id and name from $table
1006 sub get_name {
1007   my ($self, $myconfig, $table) = @_;
1008
1009   # connect to database
1010   my $dbh = $self->dbconnect($myconfig);
1011
1012   my $name = $self->like(lc $self->{$table});
1013   my $query = qq~SELECT id, name,
1014                  addr1 || ' ' || addr2 || ' ' || addr3 || ' ' || addr4 AS address
1015                  FROM $table
1016                  WHERE lower(name) LIKE '$name'
1017                  ORDER BY name~;
1018   my $sth = $dbh->prepare($query);
1019
1020   $sth->execute || $self->dberror($query);
1021
1022   my $i = 0;
1023   while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1024     push(@{ $self->{name_list} }, $ref);
1025     $i++;
1026   }
1027   $sth->finish;
1028   $dbh->disconnect;
1029
1030   $i;
1031
1032 }
1033
1034
1035 # the selection sub is used in the AR, AP, IS, IR and OE module
1036 #
1037 sub all_vc {
1038   my ($self, $myconfig, $table) = @_;
1039
1040   my $dbh = $self->dbconnect($myconfig);
1041
1042   my $query = qq|SELECT count(*) FROM $table|;
1043   my $sth = $dbh->prepare($query);
1044   $sth->execute || $self->dberror($query);
1045   my ($count) = $sth->fetchrow_array;
1046   $sth->finish;
1047
1048   # build selection list
1049   if ($count < $myconfig->{vclimit}) {
1050     $query = qq|SELECT id, name
1051                 FROM $table
1052                 ORDER BY name|;
1053     $sth = $dbh->prepare($query);
1054     $sth->execute || $self->dberror($query);
1055
1056     while (my $ref = $sth->fetchrow_hashref(NAME_lc)) {
1057       push @{ $self->{"all_$table"} }, $ref;
1058     }
1059
1060     $sth->finish;
1061
1062   }
1063
1064   $dbh->disconnect;
1065
1066 }
1067
1068
1069 sub create_links {
1070   my ($self, $module, $myconfig, $table) = @_;
1071
1072   $self->all_vc($myconfig, $table);
1073
1074   # get last customers or vendors
1075   my ($query, $sth);
1076
1077   my $dbh = $self->dbconnect($myconfig);
1078
1079   my %xkeyref = ();
1080
1081
1082   # now get the account numbers
1083   $query = qq|SELECT accno, description, link
1084               FROM chart
1085               WHERE link LIKE '%$module%'
1086               ORDER BY accno|;
1087   $sth = $dbh->prepare($query);
1088   $sth->execute || $self->dberror($query);
1089
1090   $self->{accounts} = "";
1091   while (my $ref = $sth->fetchrow_hashref(NAME_lc)) {
1092
1093     foreach my $key (split(/:/, $ref->{link})) {
1094       if ($key =~ /$module/) {
1095         # cross reference for keys
1096         $xkeyref{$ref->{accno}} = $key;
1097
1098         push @{ $self->{"${module}_links"}{$key} }, { accno => $ref->{accno},
1099                                        description => $ref->{description} };
1100
1101         $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
1102       }
1103     }
1104   }
1105   $sth->finish;
1106
1107
1108   if ($self->{id}) {
1109     my $arap = ($table eq 'customer') ? 'ar' : 'ap';
1110
1111     $query = qq|SELECT a.invnumber, a.transdate,
1112                 a.${table}_id, a.datepaid, a.duedate, a.ordnumber,
1113                 a.taxincluded, a.curr AS currency, a.notes, c.name AS $table,
1114                 a.amount AS oldinvtotal, a.paid AS oldtotalpaid
1115                 FROM $arap a, $table c
1116                 WHERE a.${table}_id = c.id
1117                 AND a.id = $self->{id}|;
1118     $sth = $dbh->prepare($query);
1119     $sth->execute || $self->dberror($query);
1120
1121     $ref = $sth->fetchrow_hashref(NAME_lc);
1122     foreach $key (keys %$ref) {
1123       $self->{$key} = $ref->{$key};
1124     }
1125     $sth->finish;
1126
1127     # get amounts from individual entries
1128     $query = qq|SELECT c.accno, c.description, a.source, a.amount,
1129                 a.transdate, a.cleared, a.project_id, p.projectnumber
1130                 FROM acc_trans a
1131                 JOIN chart c ON (c.id = a.chart_id)
1132                 LEFT JOIN project p ON (a.project_id = p.id)
1133                 WHERE a.trans_id = $self->{id}
1134                 AND a.fx_transaction = '0'
1135                 ORDER BY transdate|;
1136     $sth = $dbh->prepare($query);
1137     $sth->execute || $self->dberror($query);
1138
1139     my $fld = ($table eq 'customer') ? 'buy' : 'sell';
1140     # get exchangerate for currency
1141     $self->{exchangerate} = $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
1142
1143     # store amounts in {acc_trans}{$key} for multiple accounts
1144     while (my $ref = $sth->fetchrow_hashref(NAME_lc)) {
1145       $ref->{exchangerate} = $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
1146
1147       push @{ $self->{acc_trans}{$xkeyref{$ref->{accno}}} }, $ref;
1148     }
1149
1150     $sth->finish;
1151
1152     $query = qq|SELECT d.curr AS currencies, d.closedto, d.revtrans,
1153                   (SELECT c.accno FROM chart c
1154                    WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
1155                   (SELECT c.accno FROM chart c
1156                    WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
1157                 FROM defaults d|;
1158     $sth = $dbh->prepare($query);
1159     $sth->execute || $self->dberror($query);
1160
1161     $ref = $sth->fetchrow_hashref(NAME_lc);
1162     map { $self->{$_} = $ref->{$_} } keys %$ref;
1163     $sth->finish;
1164
1165   } else {
1166
1167     # get date
1168     $query = qq|SELECT current_date AS transdate,
1169                 d.curr AS currencies, d.closedto, d.revtrans,
1170                   (SELECT c.accno FROM chart c
1171                    WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
1172                   (SELECT c.accno FROM chart c
1173                    WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
1174                 FROM defaults d|;
1175     $sth = $dbh->prepare($query);
1176     $sth->execute || $self->dberror($query);
1177
1178     $ref = $sth->fetchrow_hashref(NAME_lc);
1179     map { $self->{$_} = $ref->{$_} } keys %$ref;
1180     $sth->finish;
1181
1182     if ($self->{"$self->{vc}_id"}) {
1183       # only setup currency
1184       ($self->{currency}) = split /:/, $self->{currencies};
1185
1186     } else {
1187
1188       $self->lastname_used($dbh, $myconfig, $table, $module);
1189
1190       my $fld = ($table eq 'customer') ? 'buy' : 'sell';
1191       # get exchangerate for currency
1192       $self->{exchangerate} = $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
1193
1194     }
1195
1196   }
1197
1198   $dbh->disconnect;
1199
1200 }
1201
1202
1203 sub lastname_used {
1204   my ($self, $dbh, $myconfig, $table, $module) = @_;
1205
1206   my $arap = ($table eq 'customer') ? "ar" : "ap";
1207   $arap = 'oe' if ($self->{type} =~ /_order/);
1208
1209   my $query = qq|SELECT id FROM $arap
1210                  WHERE id IN (SELECT MAX(id) FROM $arap
1211                               WHERE ${table}_id > 0)|;
1212   my $sth = $dbh->prepare($query);
1213   $sth->execute || $self->dberror($query);
1214
1215   my ($trans_id) = $sth->fetchrow_array;
1216   $sth->finish;
1217
1218   $trans_id *= 1;
1219   $query = qq|SELECT ct.name, a.curr, a.${table}_id,
1220               current_date + ct.terms AS duedate
1221               FROM $arap a
1222               JOIN $table ct ON (a.${table}_id = ct.id)
1223               WHERE a.id = $trans_id|;
1224   $sth = $dbh->prepare($query);
1225   $sth->execute || $self->dberror($query);
1226
1227   ($self->{$table}, $self->{currency}, $self->{"${table}_id"}, $self->{duedate}) = $sth->fetchrow_array;
1228   $sth->finish;
1229
1230 }
1231
1232
1233
1234 sub current_date {
1235   my ($self, $myconfig, $thisdate, $days) = @_;
1236
1237   my $dbh = $self->dbconnect($myconfig);
1238   my ($sth, $query);
1239
1240   $days *= 1;
1241   if ($thisdate) {
1242     my $dateformat = $myconfig->{dateformat};
1243     $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
1244
1245     $query = qq|SELECT to_date('$thisdate', '$dateformat') + $days AS thisdate
1246                 FROM defaults|;
1247      $sth = $dbh->prepare($query);
1248      $sth->execute || $self->dberror($query);
1249   } else {
1250     $query = qq|SELECT current_date AS thisdate
1251                 FROM defaults|;
1252      $sth = $dbh->prepare($query);
1253      $sth->execute || $self->dberror($query);
1254   }
1255
1256   ($thisdate) = $sth->fetchrow_array;
1257   $sth->finish;
1258
1259   $dbh->disconnect;
1260
1261   $thisdate;
1262
1263 }
1264
1265
1266 sub like {
1267   my ($self, $string) = @_;
1268
1269   unless ($string =~ /%/) {
1270     $string = "%$string%";
1271   }
1272
1273   $string =~ s/'/''/g;
1274   $string;
1275
1276 }
1277
1278
1279 sub redo_rows {
1280   my ($self, $flds, $new, $count, $numrows) = @_;
1281
1282   my @ndx = ();
1283
1284   map { push @ndx, { num => $new->[$_-1]->{runningnumber}, ndx => $_ } } (1 .. $count);
1285
1286   my $i = 0;
1287   # fill rows
1288   foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
1289     $i++;
1290     $j = $item->{ndx} - 1;
1291     map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
1292   }
1293
1294   # delete empty rows
1295   for $i ($count + 1 .. $numrows) {
1296     map { delete $self->{"${_}_$i"} } @{$flds};
1297   }
1298
1299 }
1300
1301
1302 package Locale;
1303
1304
1305 sub new {
1306   my ($type, $country, $NLS_file) = @_;
1307   my $self = {};
1308
1309   %self = ();
1310   if ($country && -d "locale/$country") {
1311     $self->{countrycode} = $country;
1312     eval { require "locale/$country/$NLS_file"; };
1313   }
1314
1315   $self->{NLS_file} = $NLS_file;
1316
1317   push @{ $self->{LONG_MONTH} }, ("January", "February", "March", "April", "May ", "June", "July", "August", "September", "October", "November", "December");
1318   push @{ $self->{SHORT_MONTH} }, (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec));
1319
1320   bless $self, $type;
1321
1322 }
1323
1324
1325 sub text {
1326   my ($self, $text) = @_;
1327
1328   return (exists $self{texts}{$text}) ? $self{texts}{$text} : $text;
1329
1330 }
1331
1332
1333 sub findsub {
1334   my ($self, $text) = @_;
1335
1336   if (exists $self{subs}{$text}) {
1337     $text = $self{subs}{$text};
1338   } else {
1339     if ($self->{countrycode} && $self->{NLS_file}) {
1340       Form->error("$text not defined in locale/$self->{countrycode}/$self->{NLS_file}");
1341     }
1342   }
1343
1344   $text;
1345
1346 }
1347
1348
1349 sub date {
1350   my ($self, $myconfig, $date, $longformat) = @_;
1351
1352   my $longdate = "";
1353   my $longmonth = ($longformat) ? 'LONG_MONTH' : 'SHORT_MONTH';
1354
1355   if ($date) {
1356     # get separator
1357     $spc = $myconfig->{dateformat};
1358     $spc =~ s/\w//g;
1359     $spc = substr($spc, 1, 1);
1360
1361     if ($spc eq '.') {
1362       $spc = '\.';
1363     }
1364     if ($spc eq '/') {
1365       $spc = '\/';
1366     }
1367
1368     if ($myconfig->{dateformat} =~ /^yy/) {
1369       ($yy, $mm, $dd) = split /$spc/, $date;
1370     }
1371     if ($myconfig->{dateformat} =~ /^mm/) {
1372       ($mm, $dd, $yy) = split /$spc/, $date;
1373     }
1374     if ($myconfig->{dateformat} =~ /^dd/) {
1375       ($dd, $mm, $yy) = split /$spc/, $date;
1376     }
1377
1378     $dd *= 1;
1379     $mm--;
1380     $yy = ($yy < 70) ? $yy + 2000 : $yy;
1381     $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1382
1383     if ($myconfig->{dateformat} =~ /^dd/) {
1384       $longdate = "$dd. ".&text($self, $self->{$longmonth}[$mm])." $yy";
1385     } else {
1386       $longdate = &text($self, $self->{$longmonth}[$mm])." $dd, $yy";
1387     }
1388
1389   }
1390
1391   $longdate;
1392
1393 }
1394
1395
1396 1;
1397