sql-ledger/SL/Form.pm

   1 #=================================================================
   2 # SQL-Ledger Accounting
   3 # Copyright (C) 2000
   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)
  12 #               Jim Rawlings <jim@your-dba.com> (DB2)
  13 #
  14 # This program is free software; you can redistribute it and/or modify
  15 # it under the terms of the GNU General Public License as published by
  16 # the Free Software Foundation; either version 2 of the License, or
  17 # (at your option) any later version.
  18 #
  19 # This program is distributed in the hope that it will be useful,
  20 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 # GNU General Public License for more details.
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program; if not, write to the Free Software
  25 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  26 #======================================================================
  27 #
  28 # main package
  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->{menubar} = 1 if $self->{path} =~ /lynx/i;
  56
  57   if (substr($self->{action}, 0, 1) !~ /( |\.)/) {
  58     $self->{action} = lc $self->{action};
  59     $self->{action} =~ s/(( |-|,|#|\/)|\.$)/_/g;
  60   }
  61
  62   $self->{version} = "2.4.4";
  63   $self->{dbversion} = "2.4.4";
  64
  65   bless $self, $type;
  66
  67 }
  68
  69
  70 sub debug {
  71   my ($self) = @_;
  72
  73   print "\n";
  74
  75   map { print "$_ = $self->{$_}\n" } (sort keys %$self);
  76
  77 }
  78
  79
  80 sub escape {
  81   my ($self, $str, $beenthere) = @_;
  82
  83   # for Apache 2 we escape strings twice
  84   if (($ENV{SERVER_SIGNATURE} =~ /Apache\/2\.(\d+)\.(\d+)/) && !$beenthere) {
  85     $str = $self->escape($str, 1) if $2 < 44;
  86   }
  87
  88   $str =~ s/([^a-zA-Z0-9_.-])/sprintf("%%%02x", ord($1))/ge;
  89   $str;
  90
  91 }
  92
  93
  94 sub unescape {
  95   my ($self, $str) = @_;
  96
  97   $str =~ tr/+/ /;
  98   $str =~ s/\\$//;
  99
 100   $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
 101
 102   $str;
 103
 104 }
 105
 106
 107 sub quote {
 108   my ($self, $str) = @_;
 109
 110   if ($str && ! ref($str)) {
 111     $str =~ s/"/&quot;/g;
 112   }
 113
 114   $str;
 115
 116 }
 117
 118
 119 sub hide_form {
 120   my $self = shift;
 121
 122   map { print qq|<input type=hidden name=$_ value="|.$self->quote($self->{$_}).qq|">\n| } sort keys %$self;
 123
 124 }
 125
 126
 127 sub error {
 128   my ($self, $msg) = @_;
 129
 130   if ($ENV{HTTP_USER_AGENT}) {
 131     $msg =~ s/\n/<br>/g;
 132
 133     delete $self->{pre};
 134
 135     if (!$self->{header}) {
 136       $self->header;
 137     }
 138
 139     print qq|<body><h2 class=error>Error!</h2>
 140
 141     <p><b>$msg</b>|;
 142
 143     exit;
 144
 145   } else {
 146
 147     if ($self->{error_function}) {
 148       &{ $self->{error_function} }($msg);
 149     } else {
 150       die "Error: $msg\n";
 151     }
 152   }
 153
 154 }
 155
 156
 157 sub info {
 158   my ($self, $msg) = @_;
 159
 160   if ($ENV{HTTP_USER_AGENT}) {
 161     $msg =~ s/\n/<br>/g;
 162
 163     delete $self->{pre};
 164
 165     if (!$self->{header}) {
 166       $self->header;
 167       print qq|
 168       <body>|;
 169       $self->{header} = 1;
 170     }
 171
 172     print "<br><b>$msg</b>";
 173
 174   } else {
 175
 176     if ($self->{info_function}) {
 177       &{ $self->{info_function} }($msg);
 178     } else {
 179       print "$msg\n";
 180     }
 181   }
 182
 183 }
 184
 185
 186
 187
 188 sub numtextrows {
 189   my ($self, $str, $cols, $maxrows) = @_;
 190
 191   my $rows = 0;
 192
 193   map { $rows += int (((length) - 2)/$cols) + 1 } split /\r/, $str;
 194
 195   $maxrows = $rows unless defined $maxrows;
 196
 197   return ($rows > $maxrows) ? $maxrows : $rows;
 198
 199 }
 200
 201
 202 sub dberror {
 203   my ($self, $msg) = @_;
 204
 205   $self->error("$msg\n".$DBI::errstr);
 206
 207 }
 208
 209
 210 sub isblank {
 211   my ($self, $name, $msg) = @_;
 212
 213   if ($self->{$name} =~ /^\s*$/) {
 214     $self->error($msg);
 215   }
 216 }
 217
 218
 219 sub header {
 220   my ($self, $init) = @_;
 221
 222   return if $self->{header};
 223
 224   my ($stylesheet, $favicon, $charset);
 225
 226   if ($ENV{HTTP_USER_AGENT}) {
 227
 228     if ($self->{stylesheet} && (-f "css/$self->{stylesheet}")) {
 229       $stylesheet = qq|<LINK REL="stylesheet" HREF="css/$self->{stylesheet}" TYPE="text/css" TITLE="SQL-Ledger stylesheet">
 230   |;
 231     }
 232
 233     if ($self->{favicon} && (-f "$self->{favicon}")) {
 234       $favicon = qq|<LINK REL="shortcut icon" HREF="$self->{favicon}" TYPE="image/x-icon">
 235   |;
 236     }
 237
 238     if ($self->{charset}) {
 239       $charset = qq|<META HTTP-EQUIV="Content-Type" CONTENT="text/plain; charset=$self->{charset}">
 240   |;
 241     }
 242
 243     $self->{titlebar} = ($self->{title}) ? "$self->{title} - $self->{titlebar}" : $self->{titlebar};
 244
 245     $self->set_cookie($init);
 246
 247     print qq|Content-Type: text/html
 248
 249 <head>
 250   <title>$self->{titlebar}</title>
 251   $favicon
 252   $stylesheet
 253   $charset
 254 </head>
 255
 256 $self->{pre}
 257 |;
 258   }
 259
 260   $self->{header} = 1;
 261
 262 }
 263
 264
 265 sub set_cookie {
 266   my ($self, $init) = @_;
 267
 268   $self->{timeout} = ($self->{timeout} > 0) ? $self->{timeout} : 3600;
 269
 270   if ($self->{endsession}) {
 271     $_ = time;
 272   } else {
 273     $_ = time + $self->{timeout};
 274   }
 275
 276   if ($ENV{HTTP_USER_AGENT}) {
 277
 278     my @d = split / +/, scalar gmtime($_);
 279     my $today = "$d[0], $d[2]-$d[1]-$d[4] $d[3] GMT";
 280
 281     if ($init) {
 282       $self->{sessionid} = time;
 283     }
 284     print qq|Set-Cookie: SQL-Ledger-$self->{login}=$self->{sessionid}; expires=$today; path=/;\n| if $self->{login};
 285   }
 286
 287 }
 288
 289
 290 sub redirect {
 291   my ($self, $msg) = @_;
 292
 293   if ($self->{callback}) {
 294
 295     ($script, $argv) = split(/\?/, $self->{callback});
 296     exec ("perl", "$script", $argv);
 297
 298   } else {
 299
 300     $self->info($msg);
 301     exit;
 302   }
 303
 304 }
 305
 306
 307 sub sort_columns {
 308   my ($self, @columns) = @_;
 309
 310   if ($self->{sort}) {
 311     if (@columns) {
 312       @columns = grep !/^$self->{sort}$/, @columns;
 313       splice @columns, 0, 0, $self->{sort};
 314     }
 315   }
 316
 317   @columns;
 318
 319 }
 320
 321
 322 sub sort_order {
 323   my ($self, $columns, $ordinal) = @_;
 324
 325   # setup direction
 326   if ($self->{direction}) {
 327     if ($self->{sort} eq $self->{oldsort}) {
 328       if ($self->{direction} eq 'ASC') {
 329         $self->{direction} = "DESC";
 330       } else {
 331         $self->{direction} = "ASC";
 332       }
 333     }
 334   } else {
 335     $self->{direction} = "ASC";
 336   }
 337   $self->{oldsort} = $self->{sort};
 338
 339   my $sortorder = join ',', $self->sort_columns(@{$columns});
 340
 341   if ($ordinal) {
 342     map { $sortorder =~ s/$_/$ordinal->{$_}/ } keys %$ordinal;
 343   }
 344   my @a = split /,/, $sortorder;
 345   $a[0] = "$a[0] $self->{direction}";
 346   $sortorder = join ',', @a;
 347
 348   $sortorder;
 349
 350 }
 351
 352
 353 sub format_amount {
 354   my ($self, $myconfig, $amount, $places, $dash) = @_;
 355
 356   if ($places =~ /\d/) {
 357     $amount = $self->round_amount($amount, $places);
 358   }
 359
 360   # is the amount negative
 361   my $negative = ($amount < 0);
 362
 363   if ($amount != 0) {
 364     if ($myconfig->{numberformat} && ($myconfig->{numberformat} ne '1000.00')) {
 365       my ($whole, $dec) = split /\./, "$amount";
 366       $whole =~ s/-//;
 367       $amount = join '', reverse split //, $whole;
 368
 369       if ($myconfig->{numberformat} eq '1,000.00') {
 370         $amount =~ s/\d{3,}?/$&,/g;
 371         $amount =~ s/,$//;
 372         $amount = join '', reverse split //, $amount;
 373         $amount .= "\.$dec" if ($dec ne "");
 374       }
 375
 376       if ($myconfig->{numberformat} eq "1'000.00") {
 377         $amount =~ s/\d{3,}?/$&'/g;
 378         $amount =~ s/'$//;
 379         $amount = join '', reverse split //, $amount;
 380         $amount .= "\.$dec" if ($dec ne "");
 381       }
 382
 383       if ($myconfig->{numberformat} eq '1.000,00') {
 384         $amount =~ s/\d{3,}?/$&./g;
 385         $amount =~ s/\.$//;
 386         $amount = join '', reverse split //, $amount;
 387         $amount .= ",$dec" if ($dec ne "");
 388       }
 389
 390       if ($myconfig->{numberformat} eq '1000,00') {
 391         $amount = "$whole";
 392         $amount .= ",$dec" if ($dec ne "");
 393       }
 394
 395       if ($dash =~ /-/) {
 396         $amount = ($negative) ? "($amount)" : "$amount";
 397       } elsif ($dash =~ /DRCR/) {
 398         $amount = ($negative) ? "$amount DR" : "$amount CR";
 399       } else {
 400         $amount = ($negative) ? "-$amount" : "$amount";
 401       }
 402     }
 403   } else {
 404     if ($dash eq "0" && $places) {
 405       if ($myconfig->{numberformat} eq '1.000,00') {
 406         $amount = "0".","."0" x $places;
 407       } else {
 408         $amount = "0"."."."0" x $places;
 409       }
 410     } else {
 411       $amount = ($dash ne "") ? "$dash" : "";
 412     }
 413   }
 414
 415   $amount;
 416
 417 }
 418
 419
 420 sub parse_amount {
 421   my ($self, $myconfig, $amount) = @_;
 422
 423   if (($myconfig->{numberformat} eq '1.000,00') ||
 424       ($myconfig->{numberformat} eq '1000,00')) {
 425     $amount =~ s/\.//g;
 426     $amount =~ s/,/\./;
 427   }
 428
 429   if ($myconfig->{numberformat} eq "1'000.00") {
 430     $amount =~ s/'//g;
 431   }
 432
 433   $amount =~ s/,//g;
 434
 435   return ($amount * 1);
 436
 437 }
 438
 439
 440 sub round_amount {
 441   my ($self, $amount, $places) = @_;
 442
 443 #  $places = 3 if $places == 2;
 444
 445   if (($places * 1) >= 0) {
 446     # add 1/10^$places+3
 447     sprintf("%.${places}f", $amount + (1 / (10 ** ($places + 3))) * (($amount > 0) ? 1 : -1));
 448   } else {
 449     $places *= -1;
 450     sprintf("%.f", $amount / (10 ** $places) + (($amount > 0) ? 0.1 : -0.1)) * (10 ** $places);
 451   }
 452
 453 }
 454
 455
 456 sub parse_template {
 457   my ($self, $myconfig, $userspath) = @_;
 458
 459   my ($chars_per_line, $lines_on_first_page, $lines_on_second_page) = (0, 0, 0);
 460   my ($current_page, $current_line) = (1, 1);
 461   my $pagebreak = "";
 462   my $sum = 0;
 463
 464   my $subdir = "";
 465   my $err = "";
 466
 467   if ($self->{language_code}) {
 468     if (-f "$self->{templates}/$self->{language_code}/$self->{IN}") {
 469       open(IN, "$self->{templates}/$self->{language_code}/$self->{IN}") or $self->error("$self->{IN} : $!");
 470     } else {
 471       open(IN, "$self->{templates}/$self->{IN}") or $self->error("$self->{IN} : $!");
 472     }
 473   } else {
 474     open(IN, "$self->{templates}/$self->{IN}") or $self->error("$self->{IN} : $!");
 475   }
 476
 477   @_ = <IN>;
 478   close(IN);
 479
 480   $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
 481
 482   # OUT is used for the media, screen, printer, email
 483   # for postscript we store a copy in a temporary file
 484   my $fileid = time;
 485   my $tmpfile = $self->{IN};
 486   $tmpfile =~ s/\./\.$self->{fileid}./ if $self->{fileid};
 487   $self->{tmpfile} = "$userspath/${fileid}.${tmpfile}";
 488
 489   if ($self->{format} =~ /(postscript|pdf)/ || $self->{media} eq 'email') {
 490     $out = $self->{OUT};
 491     $self->{OUT} = ">$self->{tmpfile}";
 492   }
 493
 494   if ($self->{OUT}) {
 495     open(OUT, "$self->{OUT}") or $self->error("$self->{OUT} : $!");
 496   } else {
 497     open(OUT, ">-") or $self->error("STDOUT : $!");
 498
 499     $self->header;
 500
 501   }
 502
 503   # first we generate a tmpfile
 504   # read file and replace <%variable%>
 505   while ($_ = shift) {
 506
 507     $par = "";
 508     $var = $_;
 509
 510
 511     # detect pagebreak block and its parameters
 512     if (/\s*<%pagebreak ([0-9]+) ([0-9]+) ([0-9]+)%>/) {
 513       $chars_per_line = $1;
 514       $lines_on_first_page = $2;
 515       $lines_on_second_page = $3;
 516
 517       while ($_ = shift) {
 518         last if (/\s*<%end pagebreak%>/);
 519         $pagebreak .= $_;
 520       }
 521     }
 522
 523
 524     if (/\s*<%foreach /) {
 525
 526       # this one we need for the count
 527       chomp $var;
 528       $var =~ s/\s*<%foreach (.+?)%>/$1/;
 529       while ($_ = shift) {
 530         last if (/\s*<%end /);
 531
 532         # store line in $par
 533         $par .= $_;
 534       }
 535
 536       # display contents of $self->{number}[] array
 537       for $i (0 .. $#{ $self->{$var} }) {
 538
 539         # Try to detect whether a manual page break is necessary
 540         # but only if there was a <%pagebreak ...%> block before
 541
 542         if ($chars_per_line) {
 543           my $lines = int(length($self->{"description"}[$i]) / $chars_per_line + 0.95);
 544           my $lpp;
 545
 546           if ($current_page == 1) {
 547             $lpp = $lines_on_first_page;
 548           } else {
 549             $lpp = $lines_on_second_page;
 550           }
 551
 552           # Yes we need a manual page break
 553           if (($current_line + $lines) > $lpp) {
 554             my $pb = $pagebreak;
 555
 556             # replace the special variables <%sumcarriedforward%>
 557             # and <%lastpage%>
 558
 559             my $psum = $self->format_amount($myconfig, $sum, 2);
 560             $pb =~ s/<%sumcarriedforward%>/$psum/g;
 561             $pb =~ s/<%lastpage%>/$current_page/g;
 562
 563             # only "normal" variables are supported here
 564             # (no <%if, no <%foreach, no <%include)
 565
 566             $pb =~ s/<%(.+?)%>/$self->{$1}/g;
 567
 568             # page break block is ready to rock
 569             print(OUT $pb);
 570             $current_page++;
 571             $current_line = 1;
 572           }
 573           $current_line += $lines;
 574         }
 575         $sum += $self->parse_amount($myconfig, $self->{"linetotal"}[$i]);
 576
 577         # don't parse par, we need it for each line
 578         print OUT $self->format_line($par, $i);
 579
 580       }
 581       next;
 582     }
 583
 584     # if not comes before if!
 585     if (/\s*<%if not /) {
 586       # check if it is not set and display
 587       chop;
 588       s/\s*<%if not (.+?)%>/$1/;
 589
 590       unless ($self->{$_}) {
 591         while ($_ = shift) {
 592           last if (/\s*<%end /);
 593
 594           # store line in $par
 595           $par .= $_;
 596         }
 597
 598         $_ = $par;
 599
 600       } else {
 601         while ($_ = shift) {
 602           last if (/\s*<%end /);
 603         }
 604         next;
 605       }
 606     }
 607
 608     if (/\s*<%if /) {
 609       # check if it is set and display
 610       chop;
 611       s/\s*<%if (.+?)%>/$1/;
 612
 613       if ($self->{$_}) {
 614         while ($_ = shift) {
 615           last if (/\s*<%end /);
 616
 617           # store line in $par
 618           $par .= $_;
 619         }
 620
 621         $_ = $par;
 622
 623       } else {
 624         while ($_ = shift) {
 625           last if (/\s*<%end /);
 626         }
 627         next;
 628       }
 629     }
 630
 631     # check for <%include filename%>
 632     if (/\s*<%include /) {
 633
 634       # get the filename
 635       chomp $var;
 636       $var =~ s/\s*<%include (.+?)%>/$1/;
 637
 638       # mangle filename
 639       $var =~ s/(\/|\.\.)//g;
 640
 641       # prevent the infinite loop!
 642       next if ($self->{"$var"});
 643
 644       unless (open(INC, "$self->{templates}/$var")) {
 645         $err = $!;
 646         $self->cleanup;
 647         $self->error("$self->{templates}/$var : $err");
 648       }
 649       unshift(@_, <INC>);
 650       close(INC);
 651
 652       $self->{"$var"} = 1;
 653
 654       next;
 655     }
 656
 657     print OUT $self->format_line($_);
 658
 659   }
 660
 661   close(OUT);
 662
 663
 664   # Convert the tex file to postscript
 665   if ($self->{format} =~ /(postscript|pdf)/) {
 666
 667     use Cwd;
 668     $self->{cwd} = cwd();
 669     $self->{tmpdir} = "$self->{cwd}/$userspath";
 670
 671     unless (chdir("$userspath")) {
 672       $err = $!;
 673       $self->cleanup;
 674       $self->error("chdir : $err");
 675     }
 676
 677     $self->{tmpfile} =~ s/$userspath\///g;
 678
 679     if ($self->{format} eq 'postscript') {
 680       system("latex --interaction=nonstopmode $self->{tmpfile} > $self->{tmpfile}.err");
 681       $self->error($self->cleanup) if ($?);
 682
 683       $self->{tmpfile} =~ s/tex$/dvi/;
 684
 685       system("dvips $self->{tmpfile} -o -q");
 686       $self->error($self->cleanup."dvips : $!") if ($?);
 687       $self->{tmpfile} =~ s/dvi$/ps/;
 688     }
 689     if ($self->{format} eq 'pdf') {
 690       system("pdflatex --interaction=nonstopmode $self->{tmpfile} > $self->{tmpfile}.err");
 691       $self->error($self->cleanup) if ($?);
 692       $self->{tmpfile} =~ s/tex$/pdf/;
 693     }
 694
 695   }
 696
 697
 698   if ($self->{format} =~ /(postscript|pdf)/ || $self->{media} eq 'email') {
 699
 700     if ($self->{media} eq 'email') {
 701
 702       use SL::Mailer;
 703
 704       my $mail = new Mailer;
 705
 706       map { $mail->{$_} = $self->{$_} } qw(cc bcc subject message version format charset);
 707       $mail->{to} = qq|$self->{email}|;
 708       $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
 709       $mail->{fileid} = "$fileid.";
 710
 711       # if we send html or plain text inline
 712       if (($self->{format} =~ /(html|txt)/) && ($self->{sendmode} eq 'inline')) {
 713         my $br = "";
 714         $br = "<br>" if $self->{format} eq 'html';
 715
 716         $mail->{contenttype} = "text/$self->{format}";
 717
 718         $mail->{message} =~ s/\r\n/$br\n/g;
 719         $myconfig->{signature} =~ s/\\n/$br\n/g;
 720         $mail->{message} .= "$br\n-- $br\n$myconfig->{signature}\n$br" if $myconfig->{signature};
 721
 722         unless (open(IN, $self->{tmpfile})) {
 723           $err = $!;
 724           $self->cleanup;
 725           $self->error("$self->{tmpfile} : $err");
 726         }
 727
 728         while (<IN>) {
 729           $mail->{message} .= $_;
 730         }
 731
 732         close(IN);
 733
 734       } else {
 735
 736         @{ $mail->{attachments} } = ($self->{tmpfile});
 737
 738         $myconfig->{signature} =~ s/\\n/\r\n/g;
 739         $mail->{message} .= "\r\n-- \r\n$myconfig->{signature}" if $myconfig->{signature};
 740
 741       }
 742
 743       if ($err = $mail->send($out)) {
 744         $self->cleanup;
 745         $self->error($err);
 746       }
 747
 748     } else {
 749
 750       $self->{OUT} = $out;
 751       unless (open(IN, $self->{tmpfile})) {
 752         $err = $!;
 753         $self->cleanup;
 754         $self->error("$self->{tmpfile} : $err");
 755       }
 756
 757       binmode(IN);
 758
 759       $self->{copies} = 1 if $self->{media} =~ /(screen|email|queue)/;
 760
 761       chdir("$self->{cwd}");
 762
 763       for my $i (1 .. $self->{copies}) {
 764         if ($self->{OUT}) {
 765           unless (open(OUT, $self->{OUT})) {
 766             $err = $!;
 767             $self->cleanup;
 768             $self->error("$self->{OUT} : $err");
 769           }
 770         } else {
 771
 772           # launch application
 773           print qq|Content-Type: application/$self->{format}
 774 Content-Disposition: attachment; filename="$self->{tmpfile}"\n\n|;
 775
 776           unless (open(OUT, ">-")) {
 777             $err = $!;
 778             $self->cleanup;
 779             $self->error("STDOUT : $err");
 780           }
 781
 782         }
 783
 784         binmode(OUT);
 785
 786         while (<IN>) {
 787           print OUT $_;
 788         }
 789
 790         close(OUT);
 791         seek IN, 0, 0;
 792       }
 793
 794       close(IN);
 795     }
 796
 797     $self->cleanup;
 798
 799   }
 800
 801 }
 802
 803
 804 sub format_line {
 805   my $self = shift;
 806
 807   $_ = shift;
 808   my $i = shift;
 809   my ($str, $pos, $l, $item, $newstr);
 810   my $var = "";
 811   my %a;
 812
 813   while (/<%(.+?)%>/) {
 814
 815     %a = ();
 816
 817     foreach $item (split / /, $1) {
 818       my ($key, $value) = split /=/, $item;
 819       if (defined $value) {
 820         $a{$key} = $value;
 821       } else {
 822         $var = $item;
 823       }
 824     }
 825
 826     $str = (defined $i) ? $self->{$var}[$i] : $self->{$var};
 827
 828     if ($a{align} || $a{width} || $a{offset}) {
 829
 830       $str =~ s/(\r|\n)+/" " x $a{offset}/ge;
 831       $l = length $str;
 832
 833       if ($l > $a{width}) {
 834         if (($pos = rindex $str, " ", $a{width}) > 0) {
 835           $newstr = substr($str, 0, $pos);
 836           $newstr .= "\n";
 837           $str = substr($str, $pos + 1);
 838
 839           while (length $str > $a{width}) {
 840             if (($pos = rindex $str, " ", $a{width}) > 0) {
 841               $newstr .= (" " x $a{offset}).substr($str, 0, $pos);
 842               $newstr .= "\n";
 843               $str = substr($str, $pos + 1);
 844             } else {
 845               $newstr .= (" " x $a{offset}).substr($str, 0, $a{width});
 846               $newstr .= "\n";
 847               $str = substr($str, $a{width} + 1);
 848             }
 849           }
 850         }
 851         $l = length $str;
 852         $str .= " " x ($a{width} - $l);
 853         $newstr .= (" " x $a{offset}).$str;
 854         $str = $newstr;
 855
 856         $l = $a{width};
 857       }
 858
 859       # pad left, right or center
 860       $pos = lc $a{align};
 861       $l = ($a{width} - $l);
 862
 863       my $pad = " " x $l;
 864
 865       if ($pos eq 'right') {
 866         $str = "$pad$str";
 867       }
 868
 869       if ($pos eq 'left') {
 870         $str = "$str$pad";
 871       }
 872
 873       if ($pos eq 'center') {
 874         $pad = " " x ($l/2);
 875         $str = "$pad$str";
 876         $pad = " " x ($l/2 + 1) if ($l % 2);
 877         $str .= "$pad";
 878       }
 879     }
 880
 881     s/<%(.+?)%>/$str/;
 882
 883   }
 884
 885   $_;
 886
 887 }
 888
 889
 890 sub cleanup {
 891   my $self = shift;
 892
 893   chdir("$self->{tmpdir}");
 894
 895   my @err = ();
 896   if (-f "$self->{tmpfile}.err") {
 897     open(FH, "$self->{tmpfile}.err");
 898     @err = <FH>;
 899     close(FH);
 900   }
 901
 902   if ($self->{tmpfile}) {
 903     # strip extension
 904     $self->{tmpfile} =~ s/\.\w+$//g;
 905     my $tmpfile = $self->{tmpfile};
 906     unlink(<$tmpfile.*>);
 907   }
 908
 909   chdir("$self->{cwd}");
 910
 911   "@err";
 912
 913 }
 914
 915
 916 sub format_string {
 917   my ($self, @fields) = @_;
 918
 919   my $format = $self->{format};
 920   if ($self->{format} =~ /(postscript|pdf)/) {
 921     $format = 'tex';
 922   }
 923
 924   my %replace = ( 'order' => { html => [ '<', '>', quotemeta('\n'), '\r' ],
 925                                txt  => [ quotemeta('\n') ],
 926                                tex  => [ '&', quotemeta('\n'), '\r',
 927                                            '\$', '%', '_', '#', quotemeta('^'),
 928                                            '{', '}', '<', '>', '£',
 929                                            quotemeta('\\\\') ] },
 930                    html => { '<' => '&lt;', '>' => '&gt;',
 931                 quotemeta('\n') => '<br>', '\r' => '<br>'
 932                             },
 933                    txt  => { quotemeta('\n') },
 934                    tex  => {
 935                 '&' => '\&', '\$' => '\$', '%' => '\%', '_' => '\_',
 936                 '#' => '\#', quotemeta('^') => '\^\\', '{' => '\{', '}' => '\}',
 937                 '<' => '$<$', '>' => '$>$',
 938                 quotemeta('\n') => '\newline ', '\r' => '\newline ',
 939                 '£' => '\pounds ', quotemeta('\\\\') => '$\backslash$'
 940                             }
 941                 );
 942
 943   foreach my $key (@{ $replace{order}{$format} }) {
 944     map { $self->{$_} =~ s/$key/$replace{$format}{$key}/g; } @fields;
 945   }
 946
 947 }
 948
 949
 950 sub datetonum {
 951   my ($self, $date, $myconfig) = @_;
 952
 953   if ($date && $date =~ /\D/) {
 954
 955     if ($myconfig->{dateformat} =~ /^yy/) {
 956       ($yy, $mm, $dd) = split /\D/, $date;
 957     }
 958     if ($myconfig->{dateformat} =~ /^mm/) {
 959       ($mm, $dd, $yy) = split /\D/, $date;
 960     }
 961     if ($myconfig->{dateformat} =~ /^dd/) {
 962       ($dd, $mm, $yy) = split /\D/, $date;
 963     }
 964
 965     $dd *= 1;
 966     $mm *= 1;
 967     $yy = ($yy < 70) ? $yy + 2000 : $yy;
 968     $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
 969
 970     $dd = "0$dd" if ($dd < 10);
 971     $mm = "0$mm" if ($mm < 10);
 972
 973     $date = "$yy$mm$dd";
 974   }
 975
 976   $date;
 977
 978 }
 979
 980
 981 # Database routines used throughout
 982
 983 sub dbconnect {
 984   my ($self, $myconfig) = @_;
 985
 986   # connect to database
 987   my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}) or $self->dberror;
 988
 989   # set db options
 990   if ($myconfig->{dboptions}) {
 991     $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
 992   }
 993
 994   $dbh;
 995
 996 }
 997
 998
 999 sub dbconnect_noauto {
1000   my ($self, $myconfig) = @_;
1001
1002   # connect to database
1003   $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, {AutoCommit => 0}) or $self->dberror;
1004
1005   # set db options
1006   if ($myconfig->{dboptions}) {
1007     $dbh->do($myconfig->{dboptions});
1008   }
1009
1010   $dbh;
1011
1012 }
1013
1014
1015 sub dbquote {
1016   my ($self, $var, $type) = @_;
1017
1018   my $rv = 'NULL';
1019
1020   # DBI does not return NULL for SQL_DATE if the date is empty, bug ?
1021   if (defined $var) {
1022     if (defined $type) {
1023       if ($type eq 'SQL_DATE') {
1024         $rv = "'$var'" if $var;
1025       } elsif ($type eq 'SQL_INT.*') {
1026         $rv = int $var;
1027       } else {
1028         if ($type !~ /SQL_.*CHAR/) {
1029           $rv = $var * 1;
1030         } else {
1031           $var =~ s/'/''/g;
1032           $rv = "'$var'";
1033         }
1034       }
1035     } else {
1036       $var =~ s/'/''/g;
1037       $rv = "'$var'";
1038     }
1039   }
1040
1041   $rv;
1042
1043 }
1044
1045
1046 sub update_balance {
1047   my ($self, $dbh, $table, $field, $where, $value) = @_;
1048
1049   # if we have a value, go do it
1050   if ($value != 0) {
1051     # retrieve balance from table
1052     my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1053     my ($balance) = $dbh->selectrow_array($query);
1054
1055     $balance += $value;
1056     # update balance
1057     $query = "UPDATE $table SET $field = $balance WHERE $where";
1058     $dbh->do($query) || $self->dberror($query);
1059   }
1060 }
1061
1062
1063
1064 sub update_exchangerate {
1065   my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1066
1067   # some sanity check for currency
1068   return if ($curr eq '');
1069
1070   my $query = qq|SELECT curr FROM exchangerate
1071                  WHERE curr = '$curr'
1072                  AND transdate = '$transdate'
1073                  FOR UPDATE|;
1074   my $sth = $dbh->prepare($query);
1075   $sth->execute || $self->dberror($query);
1076
1077   my $set;
1078   if ($buy != 0 && $sell != 0) {
1079     $set = "buy = $buy, sell = $sell";
1080   } elsif ($buy != 0) {
1081     $set = "buy = $buy";
1082   } elsif ($sell != 0) {
1083     $set = "sell = $sell";
1084   }
1085
1086   if ($sth->fetchrow_array) {
1087     $query = qq|UPDATE exchangerate
1088                 SET $set
1089                 WHERE curr = '$curr'
1090                 AND transdate = '$transdate'|;
1091   } else {
1092     $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1093                 VALUES ('$curr', $buy, $sell, '$transdate')|;
1094   }
1095   $sth->finish;
1096   $dbh->do($query) || $self->dberror($query);
1097
1098 }
1099
1100
1101 sub save_exchangerate {
1102   my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1103
1104   my $dbh = $self->dbconnect($myconfig);
1105
1106   my ($buy, $sell) = (0, 0);
1107   $buy = $rate if $fld eq 'buy';
1108   $sell = $rate if $fld eq 'sell';
1109
1110   $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1111
1112   $dbh->disconnect;
1113
1114 }
1115
1116
1117 sub get_exchangerate {
1118   my ($self, $dbh, $curr, $transdate, $fld) = @_;
1119
1120   my $query = qq|SELECT $fld FROM exchangerate
1121                  WHERE curr = '$curr'
1122                  AND transdate = '$transdate'|;
1123   my ($exchangerate) = $dbh->selectrow_array($query);
1124
1125   $exchangerate;
1126
1127 }
1128
1129
1130 sub check_exchangerate {
1131   my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1132
1133   return "" unless $transdate;
1134
1135   my $dbh = $self->dbconnect($myconfig);
1136
1137   my $query = qq|SELECT $fld FROM exchangerate
1138                  WHERE curr = '$currency'
1139                  AND transdate = '$transdate'|;
1140   my ($exchangerate) = $dbh->selectrow_array($query);
1141
1142   $dbh->disconnect;
1143
1144   $exchangerate;
1145
1146 }
1147
1148
1149 sub add_shipto {
1150   my ($self, $dbh, $id) = @_;
1151
1152   my $shipto;
1153   foreach my $item (qw(name address1 address2 city state zipcode country contact phone fax email)) {
1154     if ($self->{"shipto$item"}) {
1155       $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1156     }
1157   }
1158
1159   if ($shipto) {
1160     my $query = qq|INSERT INTO shipto (trans_id, shiptoname, shiptoaddress1,
1161                    shiptoaddress2, shiptocity, shiptostate,
1162                    shiptozipcode, shiptocountry, shiptocontact,
1163                    shiptophone, shiptofax, shiptoemail) VALUES ($id, |
1164                    .$dbh->quote($self->{shiptoname}).qq|, |
1165                    .$dbh->quote($self->{shiptoaddress1}).qq|, |
1166                    .$dbh->quote($self->{shiptoaddress2}).qq|, |
1167                    .$dbh->quote($self->{shiptocity}).qq|, |
1168                    .$dbh->quote($self->{shiptostate}).qq|, |
1169                    .$dbh->quote($self->{shiptozipcode}).qq|, |
1170                    .$dbh->quote($self->{shiptocountry}).qq|, |
1171                    .$dbh->quote($self->{shiptocontact}).qq|,
1172                    '$self->{shiptophone}', '$self->{shiptofax}',
1173                    '$self->{shiptoemail}')|;
1174     $dbh->do($query) || $self->dberror($query);
1175   }
1176
1177 }
1178
1179
1180 sub get_employee {
1181   my ($self, $dbh) = @_;
1182
1183   my $login = $self->{login};
1184   $login =~ s/@.*//;
1185   my $query = qq|SELECT name, id FROM employee
1186                  WHERE login = '$login'|;
1187   my (@a) = $dbh->selectrow_array($query);
1188   $a[1] *= 1;
1189
1190   @a;
1191
1192 }
1193
1194
1195 # this sub gets the id and name from $table
1196 sub get_name {
1197   my ($self, $myconfig, $table) = @_;
1198
1199   # connect to database
1200   my $dbh = $self->dbconnect($myconfig);
1201
1202   my $name = $self->like(lc $self->{$table});
1203   my $query = qq~SELECT c.id, c.name, c.address1, c.address2,
1204                  c.city, c.state, c.zipcode, c.country
1205                  FROM $table c
1206                  WHERE lower(c.name) LIKE '$name'
1207                  ORDER BY c.name~;
1208
1209   if ($self->{openinvoices}) {
1210     $query = qq~SELECT DISTINCT c.id, c.name, c.address1, c.address2,
1211                 c.city, c.state, c.zipcode, c.country
1212                 FROM $self->{arap} a
1213                 JOIN $table c ON (a.${table}_id = c.id)
1214                 WHERE a.amount != a.paid
1215                 AND lower(c.name) LIKE '$name'
1216                 ORDER BY c.name~;
1217   }
1218
1219   my $sth = $dbh->prepare($query);
1220
1221   $sth->execute || $self->dberror($query);
1222
1223   my $i = 0;
1224   @{ $self->{name_list} } = ();
1225   while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1226     push(@{ $self->{name_list} }, $ref);
1227     $i++;
1228   }
1229   $sth->finish;
1230   $dbh->disconnect;
1231
1232   $i;
1233
1234 }
1235
1236
1237 # the selection sub is used in the AR, AP, IS, IR and OE module
1238 #
1239 sub all_vc {
1240   my ($self, $myconfig, $table, $module, $dbh, $enddate) = @_;
1241
1242   my $ref;
1243   my $closedb;
1244   if (! defined $dbh) {
1245     $dbh = $self->dbconnect($myconfig);
1246     $closedb = 1;
1247   }
1248   my $sth;
1249
1250   my $query = qq|SELECT count(*) FROM $table|;
1251   my $where;
1252
1253   if (defined $enddate) {
1254     $where = qq|AND (enddate IS NULL OR enddate >= '$enddate')|;
1255     $query .= qq| WHERE 1=1
1256                  $where|;
1257   }
1258   my ($count) = $dbh->selectrow_array($query);
1259
1260   # build selection list
1261   if ($count < $myconfig->{vclimit}) {
1262     $query = qq|SELECT id, name
1263                 FROM $table
1264                 WHERE 1=1
1265                 $where
1266                 ORDER BY name|;
1267     $sth = $dbh->prepare($query);
1268     $sth->execute || $self->dberror($query);
1269
1270     while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1271       push @{ $self->{"all_$table"} }, $ref;
1272     }
1273     $sth->finish;
1274
1275   }
1276
1277
1278   # get self
1279   if (! $self->{employee_id}) {
1280     ($self->{employee}, $self->{employee_id}) = split /--/, $self->{employee};
1281     ($self->{employee}, $self->{employee_id}) = $self->get_employee($dbh) unless $self->{employee_id};
1282   }
1283
1284   # setup sales contacts
1285   $query = qq|SELECT id, name
1286               FROM employee
1287               WHERE sales = '1'
1288               $where
1289               ORDER BY name|;
1290   $sth = $dbh->prepare($query);
1291   $sth->execute || $self->dberror($query);
1292
1293   while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1294     push @{ $self->{all_employees} }, $ref;
1295   }
1296   $sth->finish;
1297
1298
1299   if ($module eq 'AR') {
1300     # prepare query for departments
1301     $query = qq|SELECT id, description
1302                 FROM department
1303                 WHERE role = 'P'
1304                 ORDER BY 2|;
1305
1306   } else {
1307     $query = qq|SELECT id, description
1308                 FROM department
1309                 ORDER BY 2|;
1310   }
1311
1312   $sth = $dbh->prepare($query);
1313   $sth->execute || $self->dberror($query);
1314
1315   while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1316     push @{ $self->{all_departments} }, $ref;
1317   }
1318   $sth->finish;
1319
1320
1321   # get projects
1322   $query = qq|SELECT *
1323               FROM project
1324               ORDER BY projectnumber|;
1325   $sth = $dbh->prepare($query);
1326   $sth->execute || $self->dberror($query);
1327
1328   $self->{all_projects} = ();
1329   while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1330     push @{ $self->{all_projects} }, $ref;
1331   }
1332   $sth->finish;
1333
1334   # get language codes
1335   $query = qq|SELECT *
1336               FROM language
1337               ORDER BY 2|;
1338   $sth = $dbh->prepare($query);
1339   $sth->execute || $self->dberror($query);
1340
1341   $self->{all_languages} = ();
1342   while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1343     push @{ $self->{all_languages} }, $ref;
1344   }
1345   $sth->finish;
1346
1347   $self->all_years($dbh, $myconfig);
1348
1349   $dbh->disconnect if $closedb;
1350
1351 }
1352
1353
1354 # this is only used for reports
1355 sub all_projects {
1356   my ($self, $myconfig) = @_;
1357
1358   my $dbh = $self->dbconnect($myconfig);
1359
1360   my $query = qq|SELECT *
1361                  FROM project
1362                  ORDER BY projectnumber|;
1363   $sth = $dbh->prepare($query);
1364   $sth->execute || $self->dberror($query);
1365
1366   $self->{all_projects} = ();
1367   while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1368     push @{ $self->{all_projects} }, $ref;
1369   }
1370   $sth->finish;
1371
1372   $dbh->disconnect;
1373
1374 }
1375
1376
1377 sub all_departments {
1378   my ($self, $myconfig, $table) = @_;
1379
1380   my $dbh = $self->dbconnect($myconfig);
1381   my $where = "1 = 1";
1382
1383   if (defined $table) {
1384     if ($table eq 'customer') {
1385       $where = " role = 'P'";
1386     }
1387   }
1388
1389   my $query = qq|SELECT id, description
1390                  FROM department
1391                  WHERE $where
1392                  ORDER BY 2|;
1393   my $sth = $dbh->prepare($query);
1394   $sth->execute || $self->dberror($query);
1395
1396   while (my $ref = $sth->fetchrow_hashref(NAME_lc)) {
1397     push @{ $self->{all_departments} }, $ref;
1398   }
1399   $sth->finish;
1400
1401   $self->all_years($dbh, $myconfig);
1402
1403   $dbh->disconnect;
1404
1405 }
1406
1407
1408 sub all_years {
1409   my ($self, $dbh, $myconfig) = @_;
1410
1411   # get years
1412   my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
1413                      (SELECT MAX(transdate) FROM acc_trans)
1414               FROM defaults|;
1415   my ($startdate, $enddate) = $dbh->selectrow_array($query);
1416
1417   if ($myconfig->{dateformat} =~ /^yy/) {
1418     ($startdate) = split /\W/, $startdate;
1419     ($enddate) = split /\W/, $enddate;
1420   } else {
1421     (@_) = split /\W/, $startdate;
1422     $startdate = @_[2];
1423     (@_) = split /\W/, $enddate;
1424     $enddate = @_[2];
1425   }
1426
1427   while ($enddate >= $startdate) {
1428     push @{ $self->{all_years} }, $enddate--;
1429   }
1430
1431   %{ $self->{all_month} } = ( '01' => 'January',
1432                           '02' => 'February',
1433                           '03' => 'March',
1434                           '04' => 'April',
1435                           '05' => 'May ',
1436                           '06' => 'June',
1437                           '07' => 'July',
1438                           '08' => 'August',
1439                           '09' => 'September',
1440                           '10' => 'October',
1441                           '11' => 'November',
1442                           '12' => 'December' );
1443
1444 }
1445
1446
1447 sub create_links {
1448   my ($self, $module, $myconfig, $table) = @_;
1449
1450   # get last customers or vendors
1451   my ($query, $sth);
1452
1453   my $dbh = $self->dbconnect($myconfig);
1454
1455   my %xkeyref = ();
1456
1457
1458   # now get the account numbers
1459   $query = qq|SELECT accno, description, link
1460               FROM chart
1461               WHERE link LIKE '%$module%'
1462               ORDER BY accno|;
1463   $sth = $dbh->prepare($query);
1464   $sth->execute || $self->dberror($query);
1465
1466   $self->{accounts} = "";
1467   while (my $ref = $sth->fetchrow_hashref(NAME_lc)) {
1468
1469     foreach my $key (split /:/, $ref->{link}) {
1470       if ($key =~ /$module/) {
1471         # cross reference for keys
1472         $xkeyref{$ref->{accno}} = $key;
1473
1474         push @{ $self->{"${module}_links"}{$key} }, { accno => $ref->{accno},
1475                                        description => $ref->{description} };
1476
1477         $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
1478       }
1479     }
1480   }
1481   $sth->finish;
1482
1483   if ($self->{id}) {
1484     my $arap = ($table eq 'customer') ? 'ar' : 'ap';
1485
1486     $query = qq|SELECT a.invnumber, a.transdate,
1487                 a.${table}_id, a.datepaid, a.duedate, a.ordnumber,
1488                 a.taxincluded, a.curr AS currency, a.notes, a.intnotes,
1489                 c.name AS $table, a.department_id, d.description AS department,
1490                 a.amount AS oldinvtotal, a.paid AS oldtotalpaid,
1491                 a.employee_id, e.name AS employee, c.language_code
1492                 FROM $arap a
1493                 JOIN $table c ON (a.${table}_id = c.id)
1494                 LEFT JOIN employee e ON (e.id = a.employee_id)
1495                 LEFT JOIN department d ON (d.id = a.department_id)
1496                 WHERE a.id = $self->{id}|;
1497     $sth = $dbh->prepare($query);
1498     $sth->execute || $self->dberror($query);
1499
1500     $ref = $sth->fetchrow_hashref(NAME_lc);
1501     foreach $key (keys %$ref) {
1502       $self->{$key} = $ref->{$key};
1503     }
1504     $sth->finish;
1505
1506
1507     # get printed, emailed
1508     $query = qq|SELECT s.printed, s.emailed, s.spoolfile, s.formname
1509                 FROM status s
1510                 WHERE s.trans_id = $self->{id}|;
1511     $sth = $dbh->prepare($query);
1512     $sth->execute || $form->dberror($query);
1513
1514     while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1515       $self->{printed} .= "$ref->{formname} " if $ref->{printed};
1516       $self->{emailed} .= "$ref->{formname} " if $ref->{emailed};
1517       $self->{queued} .= "$ref->{formname} $ref->{spoolfile} " if $ref->{spoolfile};
1518     }
1519     $sth->finish;
1520     map { $self->{$_} =~ s/ +$//g } qw(printed emailed queued);
1521
1522
1523     # get amounts from individual entries
1524     $query = qq|SELECT c.accno, c.description, a.source, a.amount, a.memo,
1525                 a.transdate, a.cleared, a.project_id, p.projectnumber
1526                 FROM acc_trans a
1527                 JOIN chart c ON (c.id = a.chart_id)
1528                 LEFT JOIN project p ON (p.id = a.project_id)
1529                 WHERE a.trans_id = $self->{id}
1530                 AND a.fx_transaction = '0'
1531                 ORDER BY transdate|;
1532     $sth = $dbh->prepare($query);
1533     $sth->execute || $self->dberror($query);
1534
1535
1536     my $fld = ($table eq 'customer') ? 'buy' : 'sell';
1537
1538     $self->{exchangerate} = $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
1539
1540     # store amounts in {acc_trans}{$key} for multiple accounts
1541     while (my $ref = $sth->fetchrow_hashref(NAME_lc)) {
1542       $ref->{exchangerate} = $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
1543
1544       push @{ $self->{acc_trans}{$xkeyref{$ref->{accno}}} }, $ref;
1545     }
1546     $sth->finish;
1547
1548     $query = qq|SELECT d.curr AS currencies, d.closedto, d.revtrans,
1549                   (SELECT c.accno FROM chart c
1550                    WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
1551                   (SELECT c.accno FROM chart c
1552                    WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
1553                 FROM defaults d|;
1554     $sth = $dbh->prepare($query);
1555     $sth->execute || $self->dberror($query);
1556
1557     $ref = $sth->fetchrow_hashref(NAME_lc);
1558     map { $self->{$_} = $ref->{$_} } keys %$ref;
1559     $sth->finish;
1560
1561   } else {
1562
1563     # get date
1564     $query = qq|SELECT current_date AS transdate,
1565                 d.curr AS currencies, d.closedto, d.revtrans,
1566                   (SELECT c.accno FROM chart c
1567                    WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
1568                   (SELECT c.accno FROM chart c
1569                    WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
1570                 FROM defaults d|;
1571     $sth = $dbh->prepare($query);
1572     $sth->execute || $self->dberror($query);
1573
1574     $ref = $sth->fetchrow_hashref(NAME_lc);
1575     map { $self->{$_} = $ref->{$_} } keys %$ref;
1576     $sth->finish;
1577
1578     if (! $self->{"$self->{vc}_id"}) {
1579       $self->lastname_used($dbh, $myconfig, $table, $module);
1580     }
1581
1582   }
1583
1584   $self->all_vc($myconfig, $table, $module, $dbh, $self->{transdate});
1585
1586   $dbh->disconnect;
1587
1588 }
1589
1590
1591 sub lastname_used {
1592   my ($self, $dbh, $myconfig, $table, $module) = @_;
1593
1594   my $arap = ($table eq 'customer') ? "ar" : "ap";
1595   my $where = "1 = 1";
1596   my $sth;
1597
1598   if ($self->{type} =~ /_order/) {
1599     $arap = 'oe';
1600     $where = "quotation = '0'";
1601   }
1602   if ($self->{type} =~ /_quotation/) {
1603     $arap = 'oe';
1604     $where = "quotation = '1'";
1605   }
1606
1607   my $query = qq|SELECT id FROM $arap
1608                  WHERE id IN (SELECT MAX(id) FROM $arap
1609                               WHERE $where
1610                               AND ${table}_id > 0)|;
1611   my ($trans_id) = $dbh->selectrow_array($query);
1612
1613   $trans_id *= 1;
1614
1615   my $DAYS = ($myconfig->{dbdriver} eq 'DB2') ? "DAYS" : "";
1616
1617   $query = qq|SELECT ct.name AS $table, a.curr AS currency, a.${table}_id,
1618               current_date + ct.terms $DAYS AS duedate, a.department_id,
1619               d.description AS department, ct.notes, ct.curr AS currency
1620               FROM $arap a
1621               JOIN $table ct ON (a.${table}_id = ct.id)
1622               LEFT JOIN department d ON (a.department_id = d.id)
1623               WHERE a.id = $trans_id|;
1624   $sth = $dbh->prepare($query);
1625   $sth->execute || $self->dberror($query);
1626
1627   my $ref = $sth->fetchrow_hashref(NAME_lc);
1628   map { $self->{$_} = $ref->{$_} } keys %$ref;
1629   $sth->finish;
1630
1631 }
1632
1633
1634
1635 sub current_date {
1636   my ($self, $myconfig, $thisdate, $days) = @_;
1637
1638   my $dbh = $self->dbconnect($myconfig);
1639   my ($sth, $query);
1640
1641   $days *= 1;
1642   if ($thisdate) {
1643     my $dateformat = $myconfig->{dateformat};
1644     if ($myconfig->{dateformat} !~ /^y/) {
1645       my @a = split /\D/, $thisdate;
1646       $dateformat .= "yy" if (length $a[2] > 2);
1647     }
1648
1649     if ($thisdate !~ /\D/) {
1650       $dateformat = 'yyyymmdd';
1651     }
1652
1653     if ($myconfig->{dbdriver} eq 'DB2') {
1654       $query = qq|SELECT date('$thisdate') + $days DAYS AS thisdate
1655                   FROM defaults|;
1656     } else {
1657       $query = qq|SELECT to_date('$thisdate', '$dateformat') + $days AS thisdate
1658                   FROM defaults|;
1659     }
1660
1661     $sth = $dbh->prepare($query);
1662     $sth->execute || $self->dberror($query);
1663   } else {
1664     $query = qq|SELECT current_date AS thisdate
1665                 FROM defaults|;
1666     $sth = $dbh->prepare($query);
1667     $sth->execute || $self->dberror($query);
1668   }
1669
1670   ($thisdate) = $sth->fetchrow_array;
1671   $sth->finish;
1672
1673   $dbh->disconnect;
1674
1675   $thisdate;
1676
1677 }
1678
1679
1680 sub like {
1681   my ($self, $str) = @_;
1682
1683   if ($str !~ /(%|_)/) {
1684     $str = "%$str%";
1685   }
1686
1687   $str =~ s/'/''/g;
1688   $str;
1689
1690 }
1691
1692
1693 sub redo_rows {
1694   my ($self, $flds, $new, $count, $numrows) = @_;
1695
1696   my @ndx = ();
1697
1698   map { push @ndx, { num => $new->[$_-1]->{runningnumber}, ndx => $_ } } (1 .. $count);
1699
1700   my $i = 0;
1701   # fill rows
1702   foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
1703     $i++;
1704     $j = $item->{ndx} - 1;
1705     map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
1706   }
1707
1708   # delete empty rows
1709   for $i ($count + 1 .. $numrows) {
1710     map { delete $self->{"${_}_$i"} } @{$flds};
1711   }
1712
1713 }
1714
1715
1716 sub get_partsgroup {
1717   my ($self, $myconfig, $p) = @_;
1718
1719   my $dbh = $self->dbconnect($myconfig);
1720
1721   my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
1722                  FROM partsgroup pg
1723                  JOIN parts p ON (p.partsgroup_id = pg.id)|;
1724
1725   if ($p->{searchitems} eq 'part') {
1726     $query .= qq|
1727                  WHERE p.inventory_accno_id > 0|;
1728   }
1729   if ($p->{searchitems} eq 'service') {
1730     $query .= qq|
1731                  WHERE p.inventory_accno_id IS NULL|;
1732   }
1733   if ($p->{searchitems} eq 'assembly') {
1734     $query .= qq|
1735                  WHERE p.assembly = '1'|;
1736   }
1737   if ($p->{searchitems} eq 'labor') {
1738     $query .= qq|
1739                  WHERE p.inventory_accno_id > 0 AND p.income_accno_id IS NULL|;
1740   }
1741
1742   $query .= qq|
1743                  ORDER BY partsgroup|;
1744
1745   if ($p->{all}) {
1746     $query = qq|SELECT id, partsgroup FROM partsgroup
1747                 ORDER BY partsgroup|;
1748   }
1749
1750   if ($p->{language_code}) {
1751     $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
1752                 t.description AS translation
1753                 FROM partsgroup pg
1754                 JOIN parts p ON (p.partsgroup_id = pg.id)
1755                 LEFT JOIN translation t ON (t.trans_id = pg.id AND t.language_code = '$p->{language_code}')
1756                 ORDER BY translation|;
1757   }
1758
1759   my $sth = $dbh->prepare($query);
1760   $sth->execute || $self->dberror($query);
1761
1762   $self->{all_partsgroup} = ();
1763   while (my $ref = $sth->fetchrow_hashref(NAME_lc)) {
1764     push @{ $self->{all_partsgroup} }, $ref;
1765   }
1766   $sth->finish;
1767   $dbh->disconnect;
1768
1769 }
1770
1771
1772 sub update_status {
1773   my ($self, $myconfig) = @_;
1774
1775   # no id return
1776   return unless $self->{id};
1777
1778   my $i;
1779   my $id;
1780
1781   my $dbh = $self->dbconnect_noauto($myconfig);
1782
1783   my $query = qq|DELETE FROM status
1784                  WHERE formname = |.$dbh->quote($self->{formname}).qq|
1785                  AND trans_id = ?|;
1786   my $sth = $dbh->prepare($query) || $self->dberror($query);
1787
1788   if ($self->{formname} =~ /(check|receipt)/) {
1789     for $i (1 .. $self->{rowcount}) {
1790       $sth->execute($self->{"id_$i"} * 1) || $self->dberror($query);
1791       $sth->finish;
1792     }
1793   } else {
1794     $sth->execute($self->{id}) || $self->dberror($query);
1795     $sth->finish;
1796   }
1797
1798   my $printed = ($self->{printed} =~ /$self->{formname}/) ? "1" : "0";
1799   my $emailed = ($self->{emailed} =~ /$self->{formname}/) ? "1" : "0";
1800
1801   my %queued = split / /, $self->{queued};
1802
1803   if ($self->{formname} =~ /(check|receipt)/) {
1804     # this is a check or receipt, add one entry for each lineitem
1805     my ($accno) = split /--/, $self->{account};
1806     $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname,
1807                 chart_id) VALUES (?, '$printed',|
1808                 .$dbh->quote($queued{$self->{formname}}).qq|, |
1809                 .$dbh->quote($self->{formname}).qq|,
1810                 (SELECT id FROM chart WHERE accno = |
1811                 .$dbh->quote($accno).qq|))|;
1812     $sth = $dbh->prepare($query) || $self->dberror($query);
1813
1814     for $i (1 .. $self->{rowcount}) {
1815       if ($self->{"checked_$i"}) {
1816         $sth->execute($self->{"id_$i"}) || $self->dberror($query);
1817         $sth->finish;
1818       }
1819     }
1820   } else {
1821     $query = qq|INSERT INTO status (trans_id, printed, emailed,
1822                 spoolfile, formname)
1823                 VALUES ($self->{id}, '$printed', '$emailed', |
1824                 .$dbh->quote($queued{$self->{formname}}).qq|, |
1825                 .$dbh->quote($self->{formname}).qq|)|;
1826     $dbh->do($query) || $self->dberror($query);
1827   }
1828
1829   $dbh->commit;
1830   $dbh->disconnect;
1831
1832 }
1833
1834
1835 sub save_status {
1836   my ($self, $dbh) = @_;
1837
1838   my ($query, $printed, $emailed);
1839
1840   my $formnames = $self->{printed};
1841   my $emailforms = $self->{emailed};
1842
1843   my $query = qq|DELETE FROM status
1844                  WHERE formname = '$self->{formname}'
1845                  AND trans_id = $self->{id}|;
1846   $dbh->do($query) || $self->dberror($query);
1847
1848   if ($self->{queued}) {
1849     $query = qq|DELETE FROM status
1850                 WHERE spoolfile IS NOT NULL
1851                 AND trans_id = $self->{id}|;
1852     $dbh->do($query) || $self->dberror($query);
1853
1854     my %queued = split / /, $self->{queued};
1855
1856     foreach my $formname (keys %queued) {
1857       $printed = ($self->{printed} =~ /$self->{formname}/) ? "1" : "0";
1858       $emailed = ($self->{emailed} =~ /$self->{formname}/) ? "1" : "0";
1859
1860       $query = qq|INSERT INTO status (trans_id, printed, emailed,
1861                   spoolfile, formname)
1862                   VALUES ($self->{id}, '$printed', '$emailed',
1863                   '$queued{$formname}', '$formname')|;
1864       $dbh->do($query) || $self->dberror($query);
1865       $formnames =~ s/$formname//;
1866       $emailforms =~ s/$formname//;
1867
1868     }
1869   }
1870
1871   # save printed, emailed info
1872   $formnames =~ s/^ +//g;
1873   $emailforms =~ s/^ +//g;
1874
1875   my %status = ();
1876   map { $status{$_}{printed} = 1 } split / +/, $formnames;
1877   map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
1878
1879   foreach my $formname (keys %status) {
1880     $printed = ($formnames =~ /$self->{formname}/) ? "1" : "0";
1881     $emailed = ($emailforms =~ /$self->{formname}/) ? "1" : "0";
1882
1883     $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
1884                 VALUES ($self->{id}, '$printed', '$emailed', '$formname')|;
1885     $dbh->do($query) || $self->dberror($query);
1886   }
1887
1888 }
1889
1890
1891 sub save_intnotes {
1892   my ($self, $myconfig, $table) = @_;
1893
1894   # no id return
1895   return unless $self->{id};
1896
1897   my $dbh = $self->dbconnect($myconfig);
1898
1899   my $query = qq|UPDATE $table SET
1900                  intnotes = |.$dbh->quote($self->{intnotes}).qq|
1901                  WHERE id = $self->{id}|;
1902   $dbh->do($query) || $self->dberror($query);
1903
1904   $dbh->disconnect;
1905
1906 }
1907
1908
1909 sub update_defaults {
1910   my ($self, $myconfig, $fld, $dbh) = @_;
1911
1912   my $closedb;
1913
1914   if (! defined $dbh) {
1915     $dbh = $self->dbconnect_noauto($myconfig);
1916     $closedb = 1;
1917   }
1918
1919   my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
1920   ($_) = $dbh->selectrow_array($query);
1921
1922   $_ = "0" unless $_;
1923
1924   # check for and replace
1925   # <%DATE%>, <%YYMMDD%> or variations of
1926   # <%NAME 1 1 3%>, <%BUSINESS%>, <%BUSINESS 10%>, <%CURR...%>
1927   # <%DESCRIPTION 1 1 3%>, <%ITEM 1 1 3%>, <%PARTSGROUP 1 1 3%> only for parts
1928   # <%PHONE%> for customer and vendors
1929
1930   my $num = $_;
1931   $num =~ s/(<%.*?%>)//g;
1932   ($num) = $num =~ /(\d+)/;
1933   if (defined $num) {
1934     my $incnum;
1935     # if we have leading zeros check how long it is
1936     if ($num =~ /^0/) {
1937       my $l = length $num;
1938       $incnum = $num + 1;
1939       $l -= length $incnum;
1940
1941       # pad it out with zeros
1942       my $padzero = "0" x $l;
1943       $incnum = ("0" x $l) . $incnum;
1944     } else {
1945       $incnum = $num + 1;
1946     }
1947
1948     s/$num/$incnum/;
1949   }
1950
1951   my $dbvar = $_;
1952   my $var = $_;
1953   my $str;
1954   my $param;
1955
1956   if (/<%/) {
1957     while (/<%/) {
1958       s/<%.*?%>//;
1959       last unless $&;
1960       $param = $&;
1961       $str = "";
1962
1963       if ($param =~ /<%date%>/i) {
1964         $str = ($self->split_date($myconfig->{dateformat}, $self->{transdate}))[0];
1965         $var =~ s/$param/$str/;
1966       }
1967
1968       if ($param =~ /<%(name|business|description|item|partsgroup|phone|custom)/i) {
1969         my $fld = lc $&;
1970         $fld =~ s/<%//;
1971         if ($fld =~ /name/) {
1972           if ($self->{type}) {
1973             $fld = $self->{vc};
1974           }
1975         }
1976
1977         my $p = $param;
1978         $p =~ s/(<|>|%)//g;
1979         my @p = split / /, $p;
1980         my @n = split / /, uc $self->{$fld};
1981         if ($#p > 0) {
1982           for (my $i = 1; $i <= $#p; $i++) {
1983             $str .= substr($n[$i-1], 0, $p[$i]);
1984           }
1985         } else {
1986           ($str) = split /--/, $self->{$fld};
1987         }
1988         $var =~ s/$param/$str/;
1989
1990         $var =~ s/\W//g if $fld eq 'phone';
1991       }
1992
1993       if ($param =~ /<%(yy|mm|dd)/i) {
1994         my $p = $param;
1995         $p =~ s/(<|>|%)//g;
1996         my $spc = $p;
1997         $spc =~ s/\w//g;
1998         $spc = substr($spc, 0, 1);
1999         my %d = ( yy => 1, mm => 2, dd => 3 );
2000         my @p = ();
2001
2002         my @a = $self->split_date($myconfig->{dateformat}, $self->{transdate});
2003         map { push @p, $a[$d{$_}] if ($p =~ /$_/) } sort keys %d;
2004         $str = join $spc, @p;
2005
2006         $var =~ s/$param/$str/;
2007       }
2008
2009       if ($param =~ /<%curr/i) {
2010         $var =~ s/$param/$self->{currency}/;
2011       }
2012
2013     }
2014   }
2015
2016   $query = qq|UPDATE defaults
2017               SET $fld = '$dbvar'|;
2018   $dbh->do($query) || $form->dberror($query);
2019
2020   if ($closedb) {
2021     $dbh->commit;
2022     $dbh->disconnect;
2023   }
2024
2025   $var;
2026
2027 }
2028
2029
2030 sub split_date {
2031   my ($self, $dateformat, $date) = @_;
2032
2033   my @d = localtime;
2034   my $mm;
2035   my $dd;
2036   my $yy;
2037   my $rv;
2038
2039   if (! $date) {
2040     $dd = $d[3];
2041     $mm = $d[4]++;
2042     $yy = substr($d[5],-2);
2043     $mm *= 1;
2044     $dd *= 1;
2045     $mm = "0$mm" if $mm < 10;
2046     $dd = "0$dd" if $dd < 10;
2047   }
2048
2049   if ($dateformat =~ /^yy/) {
2050     if ($date) {
2051       if ($date =~ /\D/) {
2052         ($yy, $mm, $dd) = split /\D/, $date;
2053         $mm *= 1;
2054         $dd *= 1;
2055         $mm = "0$mm" if $mm < 10;
2056         $dd = "0$dd" if $dd < 10;
2057         $yy = substr($yy, -2);
2058         $rv = "$yy$mm$dd";
2059       } else {
2060         $rv = $date;
2061       }
2062     } else {
2063       $rv = "$yy$mm$dd";
2064     }
2065   }
2066
2067   if ($dateformat =~ /^mm/) {
2068     if ($date) {
2069       if ($date =~ /\D/) {
2070         ($mm, $dd, $yy) = split /\D/, $date if $date;
2071         $mm *= 1;
2072         $dd *= 1;
2073         $mm = "0$mm" if $mm < 10;
2074         $dd = "0$dd" if $dd < 10;
2075         $yy = substr($yy, -2);
2076         $rv = "$mm$dd$yy";
2077       } else {
2078         $rv = $date;
2079       }
2080     } else {
2081       $rv = "$mm$dd$yy";
2082     }
2083   }
2084
2085   if ($dateformat =~ /^dd/) {
2086     if ($date) {
2087       if ($date =~ /\D/) {
2088         ($dd, $mm, $yy) = split /\D/, $date if $date;
2089         $mm *= 1;
2090         $dd *= 1;
2091         $mm = "0$mm" if $mm < 10;
2092         $dd = "0$dd" if $dd < 10;
2093         $yy = substr($yy, -2);
2094         $rv = "$dd$mm$yy";
2095       } else {
2096         $rv = $date;
2097       }
2098     } else {
2099       $rv = "$dd$mm$yy";
2100     }
2101   }
2102
2103   ($rv, $yy, $mm, $dd);
2104
2105 }
2106
2107
2108 sub from_to {
2109   my ($self, $yy, $mm, $interval) = @_;
2110
2111   use Time::Local;
2112
2113   my @t;
2114   my $dd = 1;
2115   my $fromdate = "$yy${mm}01";
2116   my $bd = 1;
2117
2118   if (defined $interval) {
2119     if ($interval == 12) {
2120       $yy++ if $mm > 1;
2121     } else {
2122       if (($mm += $interval) > 12) {
2123         $mm -= 12;
2124         $yy++ if $mm > 1;
2125       }
2126       if ($interval == 0) {
2127         @t = localtime(time);
2128         $dd = $t[3];
2129         $mm = $t[4] + 1;
2130         $yy = $t[5] + 1900;
2131         $bd = 0;
2132       }
2133     }
2134   } else {
2135     if ($mm++ > 12) {
2136       $mm -= 12;
2137       $yy++;
2138     }
2139   }
2140
2141   $mm--;
2142   @t = localtime(timelocal(0,0,0,$dd,$mm,$yy) - $bd);
2143
2144   $t[4]++;
2145   $t[4] = substr("0$t[4]",-2);
2146   $t[3] = substr("0$t[3]",-2);
2147
2148   ($fromdate, "$yy$t[4]$t[3]");
2149
2150 }
2151
2152
2153 sub audittrail {
2154   my ($self, $dbh, $myconfig, $audittrail) = @_;
2155
2156 # table, $reference, $formname, $action, $id, $transdate) = @_;
2157
2158   my $query;
2159   my $rv;
2160
2161   # if we have an id add audittrail, otherwise get a new timestamp
2162
2163   if ($audittrail->{id}) {
2164     $dbh = $self->dbconnect($myconfig) if $myconfig;
2165
2166     $query = qq|SELECT audittrail FROM defaults|;
2167
2168     if ($dbh->selectrow_array($query)) {
2169       my ($null, $employee_id) = $self->get_employee($dbh);
2170
2171       if ($self->{audittrail} && !$myconfig) {
2172         chop $self->{audittrail};
2173
2174         my @a = split /\|/, $self->{audittrail};
2175         my %newtrail = ();
2176         my $key;
2177         my $i;
2178         my @flds = qw(tablename reference formname action transdate);
2179
2180         # put into hash and remove dups
2181         while (@a) {
2182           $key = "$a[2]$a[3]";
2183           $i = 0;
2184           $newtrail{$key} = { map { $_ => $a[$i++] } @flds };
2185           splice @a, 0, 5;
2186         }
2187
2188         $query = qq|INSERT INTO audittrail (trans_id, tablename, reference,
2189                     formname, action, employee_id, transdate)
2190                     VALUES ($audittrail->{id}, ?, ?,
2191                     ?, ?, $employee_id, ?)|;
2192         my $sth = $dbh->prepare($query) || $self->dberror($query);
2193
2194         foreach $key (sort { $newtrail{$a}{transdate} cmp $newtrail{$b}{transdate} } keys %newtrail) {
2195           $i = 1;
2196           map { $sth->bind_param($i++, $newtrail{$key}{$_}) } @flds;
2197
2198           $sth->execute || $self->dberror;
2199           $sth->finish;
2200         }
2201       }
2202
2203
2204       if ($audittrail->{transdate}) {
2205         $query = qq|INSERT INTO audittrail (trans_id, tablename, reference,
2206                     formname, action, employee_id, transdate) VALUES (
2207                     $audittrail->{id}, '$audittrail->{tablename}', |
2208                     .$dbh->quote($audittrail->{reference}).qq|',
2209                     '$audittrail->{formname}', '$audittrail->{action}',
2210                     $employee_id, '$audittrail->{transdate}')|;
2211       } else {
2212         $query = qq|INSERT INTO audittrail (trans_id, tablename, reference,
2213                     formname, action, employee_id) VALUES ($audittrail->{id},
2214                     '$audittrail->{tablename}', |
2215                     .$dbh->quote($audittrail->{reference}).qq|,
2216                     '$audittrail->{formname}', '$audittrail->{action}',
2217                     $employee_id)|;
2218       }
2219       $dbh->do($query);
2220     }
2221   } else {
2222     $dbh = $self->dbconnect($myconfig);
2223
2224     $query = qq|SELECT current_timestamp FROM defaults|;
2225     my ($timestamp) = $dbh->selectrow_array($query);
2226
2227     $rv = "$audittrail->{tablename}|$audittrail->{reference}|$audittrail->{formname}|$audittrail->{action}|$timestamp|";
2228   }
2229
2230   $dbh->disconnect if $myconfig;
2231
2232   $rv;
2233
2234 }
2235
2236
2237
2238 package Locale;
2239
2240
2241 sub new {
2242   my ($type, $country, $NLS_file) = @_;
2243   my $self = {};
2244
2245   %self = ();
2246   if ($country && -d "locale/$country") {
2247     $self->{countrycode} = $country;
2248     eval { require "locale/$country/$NLS_file"; };
2249   }
2250
2251   $self->{NLS_file} = $NLS_file;
2252
2253   push @{ $self->{LONG_MONTH} }, ("January", "February", "March", "April", "May ", "June", "July", "August", "September", "October", "November", "December");
2254   push @{ $self->{SHORT_MONTH} }, (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec));
2255
2256   bless $self, $type;
2257
2258 }
2259
2260
2261 sub text {
2262   my ($self, $text) = @_;
2263
2264   return (exists $self{texts}{$text}) ? $self{texts}{$text} : $text;
2265
2266 }
2267
2268
2269 sub findsub {
2270   my ($self, $text) = @_;
2271
2272   if (exists $self{subs}{$text}) {
2273     $text = $self{subs}{$text};
2274   } else {
2275     if ($self->{countrycode} && $self->{NLS_file}) {
2276       Form->error("$text not defined in locale/$self->{countrycode}/$self->{NLS_file}");
2277     }
2278   }
2279
2280   $text;
2281
2282 }
2283
2284
2285 sub date {
2286   my ($self, $myconfig, $date, $longformat) = @_;
2287
2288   my $longdate = "";
2289   my $longmonth = ($longformat) ? 'LONG_MONTH' : 'SHORT_MONTH';
2290
2291
2292   if ($date) {
2293     # get separator
2294     $spc = $myconfig->{dateformat};
2295     $spc =~ s/\w//g;
2296     $spc = substr($spc, 0, 1);
2297
2298     if ($date =~ /\D/) {
2299       if ($myconfig->{dateformat} =~ /^yy/) {
2300         ($yy, $mm, $dd) = split /\D/, $date;
2301       }
2302       if ($myconfig->{dateformat} =~ /^mm/) {
2303         ($mm, $dd, $yy) = split /\D/, $date;
2304       }
2305       if ($myconfig->{dateformat} =~ /^dd/) {
2306         ($dd, $mm, $yy) = split /\D/, $date;
2307       }
2308     } else {
2309       $date = substr($date, 2);
2310       ($yy, $mm, $dd) = ($date =~ /(..)(..)(..)/);
2311     }
2312
2313     $dd *= 1;
2314     $mm--;
2315     $yy = ($yy < 70) ? $yy + 2000 : $yy;
2316     $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
2317
2318     if ($myconfig->{dateformat} =~ /^dd/) {
2319       $mm++;
2320       $dd = "0$dd" if ($dd < 10);
2321       $mm = "0$mm" if ($mm < 10);
2322       $longdate = "$dd$spc$mm$spc$yy";
2323
2324       if (defined $longformat) {
2325         $longdate = "$dd";
2326         $longdate .= ($spc eq '.') ? ". " : " ";
2327         $longdate .= &text($self, $self->{$longmonth}[--$mm])." $yy";
2328       }
2329     } elsif ($myconfig->{dateformat} =~ /^yy/) {
2330       $mm++;
2331       $dd = "0$dd" if ($dd < 10);
2332       $mm = "0$mm" if ($mm < 10);
2333       $longdate = "$yy$spc$mm$spc$dd";
2334
2335       if (defined $longformat) {
2336         $longdate = &text($self, $self->{$longmonth}[--$mm])." $dd $yy";
2337       }
2338     } else {
2339         $mm++;
2340         $dd = "0$dd" if ($dd < 10);
2341         $mm = "0$mm" if ($mm < 10);
2342         $longdate = "$mm$spc$dd$spc$yy";
2343
2344       if (defined $longformat) {
2345         $longdate = &text($self, $self->{$longmonth}[--$mm])." $dd $yy";
2346       }
2347     }
2348
2349   }
2350
2351   $longdate;
2352
2353 }
2354
2355
2356 1;
2357