1#================================================================= 2# SQL-Ledger ERP 3# Copyright (C) 2006 4# 5# Author: DWS Systems Inc. 6# Web: http://www.sql-ledger.com 7# 8#====================================================================== 9 10package Form; 11 12 13sub new { 14 my ($type, $userspath) = @_; 15 16 my $self = {}; 17 18 read(STDIN, $_, $ENV{CONTENT_LENGTH}); 19 20 if ($ENV{QUERY_STRING}) { 21 $_ = $ENV{QUERY_STRING}; 22 } 23 24 if ($ARGV[0]) { 25 $_ = $ARGV[0]; 26 } 27 28 my $data; 29 my $esc = 1; 30 31 my $windows = ($^O =~ /mswin/i); 32 33# Windows \n 34# UNIX \r\n 35 36 # if multipart form take apart on boundary 37 my ($content, $boundary) = split /; /, $ENV{CONTENT_TYPE}; 38 39 if ($boundary) { 40 (undef, $boundary) = split /=/, $boundary; 41 42 $esc = 0; 43 %$self = (); 44 45 my $var; 46 my @file = ($windows) ? split /\n/, $_ : split /\r\n/, $_; 47 48 for my $line (@file) { 49 50 last if $line =~ /${boundary}--/; 51 next if $line =~ /${boundary}/; 52 53 if ($line =~ /Content-Disposition: form-data;/) { 54 55 my @b = split /; /, $line; 56 my @c = split /=/, $b[1]; 57 $c[1] =~ s/"//g; 58 $var = $c[1]; 59 60 if ($b[2]) { 61 @c = split /=/, $b[2]; 62 $c[1] =~ s/"//g; 63 $self->{$c[0]} = $c[1]; 64 } 65 next; 66 } 67 if ($line =~ /Content-Type:/) { 68 (undef, $self->{"contenttype"}) = split /: /, $line; 69 $data = $var; 70 next; 71 } 72 73 if ($self->{$var}) { 74 $self->{$var} .= ($windows) ? "\n$line" : "\r\n$line"; 75 } else { 76 chomp $line; 77 $self->{$var} = "$line"; 78 } 79 } 80 81 if ($data) { 82 $self->{tmpfile} = time; 83 $self->{tmpfile} .= $$; 84 my (@e) = split /\./, $self->{filename}; 85 if ($#e >= 1) { 86 $self->{tmpfile} .= ".$e[$#e]"; 87 } 88 if (! open(FH, ">$userspath/$self->{tmpfile}")) { 89 if ($ENV{HTTP_USER_AGENT}) { 90 print "Content-Type: text/html\n\n"; 91 } 92 print "$userspath/$self->{tmpfile} : $!"; 93 die; 94 } 95 print FH $self->{$data}; 96 close(FH); 97 delete $self->{$data}; 98 } 99 100 } else { 101 102 %$self = split /[&=]/; 103 104 } 105 106 if ($esc) { 107 for (keys %$self) { $self->{$_} = unescape("", $self->{$_}) } 108 } 109 110 if (substr($self->{action}, 0, 1) !~ /( |\.)/) { 111 $self->{action} = lc $self->{action}; 112 $self->{action} =~ s/( |-|,|\#|\/|\.$)/_/g; 113 } 114 115 my $login = $self->{login}; 116 $login =~ s/@.*//; 117 118 $self->{admin} = ($login eq 'admin') ? 1 : 0; 119 120 $self->{menubar} = 1 if $self->{path} =~ /lynx/i; 121 122 $self->{version} = "3.2.10"; 123 $self->{dbversion} = "3.2.4"; 124 125 bless $self, $type; 126 127} 128 129 130sub debug { 131 my ($self, $file) = @_; 132 133 if ($file) { 134 open(FH, "> $file") or die $!; 135 for (sort keys %$self) { print FH "$_ = $self->{$_}\n" } 136 close(FH); 137 } else { 138 if ($ENV{HTTP_USER_AGENT}) { 139 $self->header unless $self->{header}; 140 print "<pre>"; 141 } 142 $self->{helpref} =~ s/(<a href=|>)//g; 143 for (sort keys %$self) { print "$_ = $self->{$_}\n" } 144 print "</pre>" if $ENV{HTTP_USER_AGENT}; 145 } 146 147} 148 149 150sub escape { 151 my ($self, $str, $beenthere) = @_; 152 153 # for Apache 2 we escape strings twice 154 if (($ENV{SERVER_SIGNATURE} =~ /Apache\/2\.(\d+)\.(\d+)/) && ! $beenthere) { 155 $str = $self->escape($str, 1) if $1 == 0 && $2 < 44; 156 } 157 158 $str =~ s/([^a-zA-Z0-9_.-])/sprintf("%%%02x", ord($1))/ge; 159 $str; 160 161} 162 163 164sub unescape { 165 my ($self, $str) = @_; 166 167 $str =~ tr/+/ /; 168 $str =~ s/\\$//; 169 170 $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg; 171 $str =~ s/\r?\n/\n/g; 172 173 $str; 174 175} 176 177 178sub quote { 179 my ($self, $str) = @_; 180 181 if ($str && ! ref($str)) { 182 $str =~ s/"/"/g; 183 $str =~ s/\+/\+/g; 184 } 185 186 $str; 187 188} 189 190 191sub unquote { 192 my ($self, $str) = @_; 193 194 if ($str && ! ref($str)) { 195 $str =~ s/"/"/g; 196 } 197 198 $str; 199 200} 201 202 203sub helpref { 204 my ($self, $file, $countrycode) = @_; 205 206return; # disable for now 207 208 if ($countrycode) { 209 $self->{helpref} = qq|<a href=am.pl?action=display_form&file=doc/help/$countrycode/$file&path=$self->{path}&login=$self->{login} target=_blank class=help>|; 210 } else { 211 $self->{helpref} = qq|<a href=am.pl?action=display_form&file=doc/help/$file&path=$self->{path}&login=$self->{login} target=_blank class=help>|; 212 } 213 214} 215 216 217sub retrieve_form { 218 my ($self, $myconfig, $dbh) = @_; 219 220 $self->{id} *= 1; 221 222 return unless $self->{id}; 223 224 my $disconnect; 225 226 if (! $dbh) { 227 $dbh = $self->dbconnect($myconfig); 228 $disconnect = 1; 229 } 230 231 my $query = qq|SELECT * FROM reportvars 232 WHERE reportid = $self->{id}|; 233 my $sth = $dbh->prepare($query); 234 $sth->execute || $self->dberror($query); 235 236 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) { 237 $self->{$ref->{reportvariable}} = $ref->{reportvalue}; 238 } 239 $sth->finish; 240 241 $dbh->disconnect if $disconnect; 242 243} 244 245 246sub save_form { 247 my ($self, $myconfig, $dbh) = @_; 248 249 my $disconnect; 250 251 if (! $dbh) { 252 $dbh = $self->dbconnect($myconfig); 253 $disconnect = 1; 254 } 255 256 my $query = qq|SELECT reportid FROM report 257 WHERE reportcode = 'form' 258 AND login = '$self->{login}'|; 259 ($self->{id}) = $dbh->selectrow_array($query); 260 261 $query = qq|DELETE FROM report 262 WHERE reportcode = 'form' 263 AND login = '$self->{login}'|; 264 $dbh->do($query) || $self->dberror($query); 265 266 if ($self->{id}) { 267 $query = qq|DELETE FROM reportvars 268 WHERE reportid = $self->{id}|; 269 $dbh->do($query) || $self->dberror($query); 270 271 $query = qq|INSERT INTO report (reportid, reportcode, login) 272 VALUES ($self->{id}, 'form', '$self->{login}')|; 273 } else { 274 $query = qq|INSERT INTO report (reportcode, login) 275 VALUES ('form', '$self->{login}')|; 276 } 277 $dbh->do($query) || $self->dberror($query); 278 279 $query = qq|SELECT reportid FROM report 280 WHERE reportcode = 'form' 281 AND login = '$self->{login}'|; 282 ($self->{id}) = $dbh->selectrow_array($query); 283 284 $query = qq|INSERT INTO reportvars (reportid, reportvariable, reportvalue) 285 VALUES ($self->{id}, ?, ?)|; 286 my $sth = $dbh->prepare($query) || $self->dberror($query); 287 288 my %newform; 289 for (keys %$self) { 290 if ($_ !~ /^report_/) { 291 if ($self->{$_} !~ /(HASH|ARRAY)/) { 292 $newform{$_} = $self->{$_}; 293 } 294 } 295 } 296 for (qw(initreport sessioncookie movecolumn header)) { delete $newform{$_} } 297 298 for (keys %newform) { 299 $sth->execute("$_", "$self->{$_}"); 300 $sth->finish; 301 } 302 303 $dbh->disconnect if $disconnect; 304 305} 306 307 308sub select_option { 309 my ($self, $list, $selected, $removeid, $rev) = @_; 310 311 my $str; 312 my @opt = split /\r?\n/, $self->unescape($list); 313 my $var; 314 315 for (@opt) { 316 $var = $_ = $self->quote($_); 317 if ($rev) { 318 $_ =~ s/--.*//g; 319 $var =~ s/.*--//g; 320 } 321 if ($removeid) { 322 $var =~ s/--.*//g; 323 } 324 325 $str .= qq|<option value="$_"|; 326 $str .= qq| selected| if (($_ ne "") && ($_ eq $self->quote($selected))); 327 $str .= qq|>$var\n|; 328 } 329 330 $str; 331 332} 333 334 335sub hide_form { 336 my $self = shift; 337 338 my $str; 339 340 if (@_) { 341 for (@_) { $str .= qq|<input type="hidden" name="$_" value="|.$self->quote($self->{$_}).qq|">\n| } 342 print qq|$str| if $self->{header}; 343 } else { 344 delete $self->{header}; 345 for (sort keys %$self) { 346 print qq|<input type="hidden" name="$_" value="|.$self->quote($self->{$_}).qq|">\n|; 347 } 348 } 349 350 $str; 351 352} 353 354 355sub error { 356 my ($self, $msg) = @_; 357 358 if ($ENV{HTTP_USER_AGENT}) { 359 $self->{msg} = $msg; 360 $self->{format} = "html"; 361 $self->format_string((msg)); 362 363 delete $self->{pre}; 364 365 if (! $self->{header}) { 366 $self->header(0,1); 367 } 368 369 print qq|<body><h2 class=error>Error!</h2> 370 371 <p><b>$self->{msg}</b>|; 372 373 exit; 374 375 } 376 377 die "Error: $msg\n"; 378 379} 380 381 382sub info { 383 my ($self, $msg) = @_; 384 385 if ($ENV{HTTP_USER_AGENT}) { 386 $msg =~ s/\n/<br>/g; 387 388 delete $self->{pre}; 389 390 unless ($self->{header}) { 391 $self->header(0,1); 392 print qq| 393 <body>|; 394 } 395 396 print "<b>$msg</b>"; 397 398 } else { 399 400 print "$msg\n"; 401 402 } 403 404} 405 406 407sub numtextrows { 408 my ($self, $str, $cols, $maxrows) = @_; 409 410 my $rows = 0; 411 412 $str =~ s/<br>/\n/g; 413 414 for (split /\n/, $str) { $rows += int (((length) - 2)/$cols) + 1 } 415 $maxrows = $rows unless defined $maxrows; 416 417 return ($rows > $maxrows) ? $maxrows : $rows; 418 419} 420 421 422sub dberror { 423 my ($self, $msg) = @_; 424 425 $self->error("$msg\n".$DBI::errstr); 426 427} 428 429 430sub isblank { 431 my ($self, $name, $msg) = @_; 432 433 $self->error($msg) if $self->{$name} =~ /^\s*$/; 434 435} 436 437 438sub header { 439 my ($self, $endsession, $nocookie) = @_; 440 441 return if $self->{header}; 442 443 my ($stylesheet, $favicon, $charset); 444 445 if ($ENV{HTTP_USER_AGENT}) { 446 447 if ($self->{stylesheet} && (-f "css/$self->{stylesheet}")) { 448 $stylesheet = qq|<LINK REL="stylesheet" HREF="css/$self->{stylesheet}" TYPE="text/css" TITLE="SQL-Ledger stylesheet"> 449 |; 450 } 451 452 if ($self->{favicon} && (-f "$self->{favicon}")) { 453 $favicon = qq|<LINK REL="icon" HREF="$self->{favicon}" TYPE="image/x-icon"> 454<LINK REL="shortcut icon" HREF="$self->{favicon}" TYPE="image/x-icon"> 455 |; 456 } 457 458 if ($self->{charset}) { 459 $charset = qq|<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=$self->{charset}"> 460 |; 461 } 462 463 my $title = ($self->{title}) ? $self->{title} : "SQL-Ledger"; 464 465 $self->set_cookie($endsession) unless $nocookie; 466 467 print qq|Content-Type: text/html 468 469<head> 470 <title>$title</title> 471 <META NAME="robots" CONTENT="noindex,nofollow" /> 472 $favicon 473 $stylesheet 474 $charset 475</head> 476 477$self->{pre} 478|; 479 } 480 481 $self->{header} = 1; 482 delete $self->{sessioncookie}; 483 484} 485 486 487sub set_cookie { 488 my ($self, $endsession) = @_; 489 490 $self->{timeout} ||= 31557600; 491 my $t = ($endsession) ? time : time + $self->{timeout}; 492 493 if ($ENV{HTTP_USER_AGENT}) { 494 my @d = split / +/, scalar gmtime($t); 495 496 my $today = "$d[0], $d[2]-$d[1]-$d[4] $d[3] GMT"; 497 my $login = ($self->{login}) ? $self->{login} : 'root'; 498 499 $login =~ s/(\@| )/_/g; 500 501 if ($login) { 502 if ($self->{sessioncookie}) { 503 print qq|Set-Cookie: SL-${login}=$self->{sessioncookie}; expires=$today; path=/;\n|; 504 } else { 505 print qq|Set-Cookie: SL-${login}=; expires=$today; path=/;\n|; 506 } 507 } 508 } 509 510} 511 512 513sub redirect { 514 my ($self, $msg) = @_; 515 516 if ($self->{callback}) { 517 518 my ($script, $argv) = split(/\?/, $self->{callback}); 519 my @args = ('perl', $script, $argv); 520 exec (@args) or $self->error("$args[0] $args[1]: $!");; 521 522 } else { 523 524 $self->info($msg); 525 526 } 527 528} 529 530 531sub sort_columns { 532 my ($self, @columns) = @_; 533 534 if ($self->{sort}) { 535 $self->{sort} = "" if $self->{sort} =~ s/;//g; 536 if (@columns) { 537 @columns = grep !/^$self->{sort}$/, @columns; 538 splice @columns, 0, 0, $self->{sort}; 539 } 540 } 541 542 @columns; 543 544} 545 546 547sub sort_order { 548 my ($self, $columns, $ordinal) = @_; 549 550 # setup direction 551 if ($self->{direction}) { 552 if ($self->{sort} eq $self->{oldsort}) { 553 if ($self->{direction} eq 'ASC') { 554 $self->{direction} = "DESC"; 555 } else { 556 $self->{direction} = "ASC"; 557 } 558 } 559 } else { 560 $self->{direction} = "ASC"; 561 } 562 $self->{oldsort} = $self->{sort}; 563 564 my @sf = $self->sort_columns(@{$columns}); 565 if (%$ordinal) { 566 $sf[0] = ($ordinal->{$sf[$_]}) ? "$ordinal->{$sf[0]} $self->{direction}" : "$sf[0] $self->{direction}"; 567 for (1 .. $#sf) { $sf[$_] = $ordinal->{$sf[$_]} if $ordinal->{$sf[$_]} } 568 } else { 569 $sf[0] .= " $self->{direction}"; 570 } 571 572 $sortorder = join ',', @sf; 573 574 $sortorder; 575 576} 577 578 579sub ordinal_order { 580 my ($self, $dbh, $query) = @_; 581 582 return unless ($dbh && $query); 583 my %ordinal = (); 584 585 my $sth = $dbh->prepare($query); 586 $sth->execute || $self->dberror($query); 587 for (0 .. $sth->{NUM_OF_FIELDS} - 1) { $ordinal{$sth->{NAME_lc}->[$_]} = $_ + 1 } 588 $sth->finish; 589 590 %ordinal; 591 592} 593 594 595sub format_amount { 596 my ($self, $myconfig, $amount, $places, $dash) = @_; 597 598 if ($places =~ /\d+/) { 599 $amount = $self->round_amount($amount, $places); 600 } 601 602 # is the amount negative 603 my $negative = ($amount < 0); 604 605 if ($amount) { 606 if ($myconfig->{numberformat}) { 607 my ($whole, $dec) = split /\./, "$amount"; 608 $whole =~ s/-//; 609 $amount = join '', reverse split //, $whole; 610 if ($places) { 611 $dec .= "0" x $places; 612 $dec = substr($dec, 0, $places); 613 } 614 615 if ($myconfig->{numberformat} eq '1,000.00') { 616 $amount =~ s/\d{3,}?/$&,/g; 617 $amount =~ s/,$//; 618 $amount = join '', reverse split //, $amount; 619 $amount .= "\.$dec" if ($dec ne ""); 620 } 621 622 if ($myconfig->{numberformat} eq "1'000.00") { 623 $amount =~ s/\d{3,}?/$&'/g; 624 $amount =~ s/'$//; 625 $amount = join '', reverse split //, $amount; 626 $amount .= "\.$dec" if ($dec ne ""); 627 } 628 629 if ($myconfig->{numberformat} eq '1.000,00') { 630 $amount =~ s/\d{3,}?/$&./g; 631 $amount =~ s/\.$//; 632 $amount = join '', reverse split //, $amount; 633 $amount .= ",$dec" if ($dec ne ""); 634 } 635 636 if ($myconfig->{numberformat} eq '1000,00') { 637 $amount = "$whole"; 638 $amount .= ",$dec" if ($dec ne ""); 639 } 640 641 if ($myconfig->{numberformat} eq '1000.00') { 642 $amount = "$whole"; 643 $amount .= ".$dec" if ($dec ne ""); 644 } 645 646 if ($myconfig->{numberformat} eq '100000') { 647 $amount = "$whole$dec"; 648 } 649 650 if ($dash =~ /-/) { 651 $amount = ($negative) ? "($amount)" : "$amount"; 652 } elsif ($dash =~ /DRCR/) { 653 $amount = ($negative) ? "$amount DR" : "$amount CR"; 654 } else { 655 $amount = ($negative) ? "-$amount" : "$amount"; 656 } 657 } 658 } else { 659 if ($dash eq "0" && $places) { 660 if ($myconfig->{numberformat} eq '1.000,00') { 661 $amount = "0".","."0" x $places; 662 } else { 663 $amount = "0"."."."0" x $places; 664 } 665 } else { 666 $amount = ($dash ne "") ? "$dash" : ""; 667 } 668 } 669 670 $amount; 671 672} 673 674 675sub parse_amount { 676 my ($self, $myconfig, $amount) = @_; 677 678 if (($myconfig->{numberformat} eq '1.000,00') || 679 ($myconfig->{numberformat} eq '1000,00')) { 680 $amount =~ s/\.//g; 681 $amount =~ s/,/\./; 682 } 683 684 if ($myconfig->{numberformat} eq "1'000.00") { 685 $amount =~ s/'//g; 686 } 687 688 $amount =~ s/,//g; 689 690 return ($amount * 1); 691 692} 693 694 695sub round_amount { 696 my ($self, $amount, $places) = @_; 697 698 $amount *= 1; 699 $places *= 1; 700 701 my $neg = ($amount < 0) ? -1 : 1; 702 703 return int(($amount * (10**$places)) + ($neg * 0.501)) / (10**$places); 704 705} 706 707 708sub parse_template { 709 my ($self, $myconfig, $userspath, $dvipdf, $xelatex) = @_; 710 711 my $err; 712 my $ok; 713 714 if (-f "$self->{templates}/$self->{language_code}/$self->{IN}") { 715 open(IN, "$self->{templates}/$self->{language_code}/$self->{IN}") or $self->error("$self->{templates}/$self->{language_code}/$self->{IN} : $!"); 716 } else { 717 open(IN, "$self->{templates}/$self->{IN}") or $self->error("$self->{templates}/$self->{IN} : $!"); 718 } 719 720 my @template = <IN>; 721 close(IN); 722 723 # OUT is used for the media, screen, printer, email 724 # for postscript we store a copy in a temporary file 725 my $fileid = time; 726 $fileid .= $$; 727 my $tmpfile = $self->{IN}; 728 $tmpfile =~ s/\./_$self->{fileid}./ if $self->{fileid}; 729 $self->{tmpfile} = "$userspath/${fileid}_${tmpfile}"; 730 731 if ($self->{format} =~ /(ps|pdf)/ || $self->{media} eq 'email') { 732 $out = $self->{OUT}; 733 $self->{OUT} = ">$self->{tmpfile}"; 734 } 735 736 if ($self->{OUT}) { 737 open(OUT, "$self->{OUT}") or $self->error("$self->{OUT} : $!"); 738 } else { 739 open(OUT, ">-") or $self->error("STDOUT : $!"); 740 741 $self->header; 742 743 } 744 745 $self->{copies} ||= 1; 746 747 # first we generate a tmpfile 748 # read file and replace <%variable%> 749 750 $self->{copy} = ""; 751 752 for my $i (1 .. $self->{copies}) { 753 754 $sum = 0; 755 $self->{copy} = 1 if $i == 2; 756 757 if ($self->{format} =~ /(ps|pdf)/ && $self->{copies} > 1) { 758 if ($i == 1) { 759 @_ = (); 760 while ($_ = shift @template) { 761 if (/\\end\{document\}/) { 762 push @_, qq|\\newpage\n|; 763 last; 764 } 765 push @_, $_; 766 } 767 @template = @_; 768 } 769 770 if ($i == 2) { 771 while ($_ = shift @template) { 772 last if /\\begin\{document\}/; 773 } 774 } 775 776 if ($i == $self->{copies}) { 777 push @template, q|\end\{document\}|; 778 } 779 } 780 781 print OUT $self->process_template($myconfig, @template); 782 783 } 784 785 close(OUT); 786 787 788 # Convert the tex file to postscript 789 if ($self->{format} =~ /(ps|pdf)/) { 790 $self->run_latex($userspath, $dvipdf, $xelatex); 791 if (-f "$self->{errfile}") { 792 open(FH, "$self->{errfile}"); 793 my @err = <FH>; 794 close(FH); 795 for (@err) { 796 $self->error("@err") if /LaTeX Error:/; 797 } 798 } 799 } 800 801 if ($self->{format} =~ /(ps|pdf)/ || $self->{media} eq 'email') { 802 803 if ($self->{media} eq 'email') { 804 805 use SL::Mailer; 806 807 my $mail = new Mailer; 808 809 for (qw(email cc bcc)) { $self->{$_} =~ s/(\\|\>|\<|<|>)//g; } 810 for (qw(cc bcc subject message version format notify)) { $mail->{$_} = $self->{$_} } 811 $mail->{charset} = $self->{charset}; 812 $mail->{to} = $self->{email}; 813 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|; 814 $mail->{fileid} = "${fileid}."; 815 816 # if we send html or plain text inline 817 if (($self->{format} =~ /(html|txt|xml)/) && ($self->{sendmode} eq 'inline')) { 818 my $br = ""; 819 $br = "<br>" if $self->{format} eq 'html'; 820 821 $mail->{contenttype} = "text/$self->{format}"; 822 823 $mail->{message} =~ s/\r?\n/$br\n/g; 824 $myconfig->{signature} =~ s/\\n/$br\n/g; 825 $mail->{message} .= "$br\n-- $br\n$myconfig->{signature}\n$br" if $myconfig->{signature}; 826 827 unless (open(IN, $self->{tmpfile})) { 828 $err = $!; 829 $self->cleanup; 830 $self->error("$self->{tmpfile} : $err"); 831 } 832 833 while (<IN>) { 834 $mail->{message} .= $_; 835 } 836 837 close(IN); 838 839 } else { 840 841 @{ $mail->{attachments} } = ($self->{tmpfile}); 842 843 $myconfig->{signature} =~ s/\\n/\n/g; 844 $mail->{message} .= "\n-- \n$myconfig->{signature}" if $myconfig->{signature}; 845 846 } 847 848 if ($err = $mail->send($out)) { 849 $self->cleanup; 850 $self->error($err); 851 } 852 853 } else { 854 855 $self->process_tex($out); 856 857 } 858 859 $self->cleanup; 860 861 } 862 863} 864 865 866sub process_template { 867 my $self = shift; 868 my $myconfig = shift; 869 870 my $var; 871 my $par; 872 my $str; 873 874 my ($chars_per_line, $lines_on_first_page, $lines_on_second_page) = (0, 0, 0); 875 my ($current_page, $current_line) = (1, 1); 876 my $sum; 877 my $pagebreak = ""; 878 my %include; 879 880 while ($_ = shift) { 881 882 $par = ""; 883 884 # detect pagebreak block and its parameters 885 if (/<%pagebreak ([0-9]+) ([0-9]+) ([0-9]+)%>/) { 886 $chars_per_line = $1; 887 $lines_on_first_page = $2; 888 $lines_on_second_page = $3; 889 890 while ($_ = shift) { 891 last if (/<%end pagebreak%>/); 892 $pagebreak .= $_; 893 } 894 } 895 896 if (/<%foreach /) { 897 898 # this one we need for the count 899 chomp; 900 s/.*?<%foreach\s+?(.+?)%>/$1/; 901 $var = $1; 902 while ($_ = shift) { 903 last if /<%end\s+?\Q$var\E%>/; 904 905 # store line in $par 906 $par .= $_; 907 } 908 909 my $v = time; 910 my $i; 911 912 if ($var =~ /\*/) { 913 my @v = split / /, $var; 914 $v = $v[2]; 915 $var =~ s/\s+\*.*//; 916 } else { 917 for $i (0 .. $#{ $self->{$var} }) { 918 push @{ $self->{$v} }, 1; 919 } 920 } 921 922 # display contents of $self->{number}[] array 923 for $i (0 .. $#{ $self->{$var} }) { 924 925 for my $k (1 .. $self->{$v}[$i]) { 926 927 if ($var =~ /^(part|service)$/) { 928 next if $self->{$var}[$i] eq 'NULL'; 929 } 930 931 # Try to detect whether a manual page break is necessary 932 # but only if there was a <%pagebreak ...%> block before 933 934 if ($var eq 'number' || $var eq 'part' || $var eq 'service') { 935 if ($chars_per_line && $self->{$var}) { 936 my $line; 937 my $lines = 0; 938 my $item = $self->{description}[$i]; 939 $item .= "\n".$self->{itemnotes}[$i] if $self->{itemnotes}[$i]; 940 941 foreach $line (split /\r?\n/, $item) { 942 $lines++; 943 $lines += int(length($line) / $chars_per_line); 944 } 945 946 my $lpp; 947 948 if ($current_page == 1) { 949 $lpp = $lines_on_first_page; 950 } else { 951 $lpp = $lines_on_second_page; 952 } 953 954 # Yes we need a manual page break 955 if (($current_line + $lines) > $lpp) { 956 my $pb = $pagebreak; 957 958 # replace the special variables <%sumcarriedforward%> 959 # and <%lastpage%> 960 961 my $psum = $self->format_amount($myconfig, $sum, $self->{precision}); 962 $pb =~ s/<%sumcarriedforward%>/$psum/g; 963 $pb =~ s/<%lastpage%>/$current_page/g; 964 965 # only "normal" variables are supported here 966 # (no <%if, no <%foreach, no <%include) 967 968 $pb =~ s/<%(.+?)%>/$self->{$1}/g; 969 970 # page break block is ready to rock 971 $str .= $pb; 972 973 $current_page++; 974 $current_line = 1; 975 $lines = 0; 976 } 977 $current_line += $lines; 978 } 979 $sum += $self->parse_amount($myconfig, $self->{linetotal}[$i]); 980 } 981 982 # don't parse par, we need it for each line 983 $str .= $self->format_line($par, $i); 984 985 } 986 } 987 next; 988 } 989 990 if (/<%else /) { 991 # check if it is not set and display 992 chomp; 993 s/.*?<%else\s+?(.+?)%>/$1/; 994 $var = $1; 995 996 if (! $self->{$var}) { 997 s/^$var//; 998 if (/<%end /) { 999 s/<%end\s+?$var%>//; 1000 } else { 1001 $par = $_; 1002 while ($_ = shift) { 1003 last if /<%end /; 1004 # store line in $par 1005 $par .= $_; 1006 } 1007 $_ = $par; 1008 } 1009 } else { 1010 if (! /<%end /) { 1011 while ($_ = shift) { 1012 last if /<%end /; 1013 } 1014 } 1015 next; 1016 } 1017 } 1018 1019 if (/<%if\s+?not /) { 1020 # check if it is not set and display 1021 chomp; 1022 s/.*?<%if\s+?not\s+?(.+?)%>/$1/; 1023 $var = $1; 1024 1025 if (! $self->{$var}) { 1026 s/^$var//; 1027 if (/<%else\s*?%>/) { 1028 s/<%else\s*?%>.*?(<%end\s+?$var%>)/$1/; 1029 } 1030 if (/<%end /) { 1031 s/<%end\s+?$var%>//; 1032 } else { 1033 $par = $_; 1034 while ($_ = shift) { 1035 last if /<%end /; 1036 # store line in $par 1037 $par .= $_; 1038 } 1039 $_ = $par; 1040 } 1041 } else { 1042 if (! /<%(end|else) /) { 1043 while ($_ = shift) { 1044 last if /<%(end|else) /; 1045 } 1046 } 1047 next; 1048 } 1049 } 1050 1051 if (/<%if /) { 1052 # check if it is set and display 1053 chomp; 1054 s/.*?<%if\s+?(.+?)%>/$1/; 1055 $var = $1; 1056 $ok = 0; 1057 if ($var =~ /\s/) { 1058 my @k = split / /, $var, 3; 1059 if ($#k == 2) { 1060 for my $j (0 .. 2) { 1061 $temp = $k[$j]; 1062 if ($temp !~ /'/) { 1063 if (exists $self->{$temp}) { 1064 $k[$j] = qq|'$self->{$temp}'|; 1065 } 1066 } 1067 } 1068 $ok = eval qq|$k[0] $k[1] $k[2]|; 1069 } 1070 } else { 1071 $ok = $self->{$var}; 1072 } 1073 1074 if ($ok) { 1075 s/^$var//; 1076 if (/<%else\s*?%>/) { 1077 s/<%else\s*?%>.*?(<%end\s+?$var%>)/$1/; 1078 } 1079 if (/<%end /) { 1080 s/<%end\s+?$var%>//; 1081 } else { 1082 $par = $_; 1083 while ($_ = shift) { 1084 last if /<%end /; 1085 # store line in $par 1086 $par .= $_; 1087 } 1088 $_ = $par; 1089 } 1090 } else { 1091 if (! /<%(end|else) /) { 1092 while ($_ = shift) { 1093 last if /<%(end|else) /; 1094 } 1095 } 1096 next; 1097 } 1098 } 1099 1100 # check for <%include something filename%> 1101 if (/<%include /) { 1102 1103 $var = $_; 1104 $var =~ s/(\s*?<%|%>)//g; 1105 my @k = split / /, $var; 1106 1107 if ($#k > 1) { 1108 # get the filename 1109 $var = $k[2]; 1110 1111 unless (open(INC, "$self->{templates}/$self->{language_code}/$var")) { 1112 $err = $!; 1113 $self->cleanup; 1114 $self->error("$self->{templates}/$self->{language_code}/$var : $err"); 1115 } 1116 my @include = <INC>; 1117 close(INC); 1118 1119 $include{"include$var"}++; 1120 1121 $tmpfile = $self->{tmpfile}; 1122 $tmpfile =~ s/\.\w+$//g; 1123 $tmpfile .= qq|.$include{"include$var"}|; 1124 1125 unless (open(INC, ">$tmpfile")) { 1126 $err = $!; 1127 $self->cleanup; 1128 $self->error("$tmpfile : $err"); 1129 } 1130 print INC $self->process_template($myconfig, @include); 1131 close(INC); 1132 1133 $tmpfile =~ s/.*?\///; 1134 $str .= qq|$k[1]\{$tmpfile\}|; 1135 1136 next; 1137 } 1138 } 1139 1140 # check for <%include filename%> 1141 if (/<%include /) { 1142 1143 # get the filename 1144 chomp; 1145 s/.*?<%include\s+?(.+?)%>/$1/; 1146 $var = $1; 1147 1148 # remove / .. 1149 $var =~ s/(\/|\.\.)//g; 1150 1151 # assume loop after 10 includes of the same file 1152 next if $include{$var} > 10; 1153 1154 unless (open(INC, "$self->{templates}/$self->{language_code}/$var")) { 1155 $err = $!; 1156 $self->cleanup; 1157 $self->error("$self->{templates}/$self->{language_code}/$var : $err"); 1158 } 1159 unshift(@_, <INC>); 1160 close(INC); 1161 1162 $include{$var}++; 1163 1164 next; 1165 } 1166 1167 $str .= $self->format_line($_); 1168 1169 } 1170 1171 $str; 1172 1173} 1174 1175 1176sub run_latex { 1177 my ($self, $userspath, $dvipdf, $xelatex) = @_; 1178 1179 use Cwd; 1180 $self->{cwd} = cwd(); 1181 $self->{tmpdir} = "$self->{cwd}/$userspath"; 1182 1183 my $err; 1184 1185 unless (chdir("$userspath")) { 1186 $err = $!; 1187 $self->cleanup; 1188 $self->error("chdir : $err"); 1189 } 1190 1191 $self->{tmpfile} =~ s/$userspath\///g; 1192 1193 $self->{errfile} = $self->{tmpfile}; 1194 $self->{errfile} =~ s/tex$/err/; 1195 1196 my $r = 1; 1197 1198 if ($self->{format} eq 'ps') { 1199 system("latex --interaction=nonstopmode $self->{tmpfile} > $self->{errfile}"); 1200 while ($self->rerun_latex) { 1201 system("latex --interaction=nonstopmode $self->{tmpfile} > $self->{errfile}"); 1202 last if ++$r > 4; 1203 } 1204 $self->{tmpfile} =~ s/tex$/dvi/; 1205 $self->error($self->cleanup) if ! (-f $self->{tmpfile}); 1206 1207 if ($self->{format} eq 'ps') { 1208 system("dvips $self->{tmpfile} -o -q"); 1209 $self->error($self->cleanup."dvips : $!") if ($?); 1210 $self->{tmpfile} =~ s/dvi$/ps/; 1211 } 1212 } 1213 1214 if ($self->{format} eq 'pdf') { 1215 1216 if ($dvipdf) { 1217 system("latex --interaction=nonstopmode $self->{tmpfile} > $self->{errfile}"); 1218 while ($self->rerun_latex) { 1219 system("latex --interaction=nonstopmode $self->{tmpfile} > $self->{errfile}"); 1220 last if ++$r > 4; 1221 } 1222 $self->{tmpfile} =~ s/tex$/dvi/; 1223 $self->error($self->cleanup) if ! (-f $self->{tmpfile}); 1224 1225 system("dvipdf $self->{tmpfile}"); 1226 $self->error($self->cleanup."dvipdf : $!") if ($?); 1227 $self->{tmpfile} =~ s/dvi$/pdf/; 1228 1229 } else { 1230 $lt = ($xelatex) ? "xelatex" : "pdflatex"; 1231 system("$lt --interaction=nonstopmode $self->{tmpfile} > $self->{errfile}"); 1232 while ($self->rerun_latex) { 1233 system("$lt --interaction=nonstopmode $self->{tmpfile} > $self->{errfile}"); 1234 last if ++$r > 4; 1235 } 1236 $self->{tmpfile} =~ s/tex$/pdf/; 1237 $self->error($self->cleanup) if ! (-f $self->{tmpfile}); 1238 } 1239 } 1240 1241} 1242 1243 1244sub gentex { 1245 my ($self, $myconfig, $templates, $userspath, $dvipdf, $xelatex, $column, $hdr) = @_; 1246 1247 my $fileid = time; 1248 $fileid .= $$; 1249 $self->{tmpfile} = "$userspath/${fileid}.tex"; 1250 1251 open(HDR, "$templates/$myconfig->{templates}/$self->{language_code}/invoice.tex") or $self->error("$templates/$myconfig->{templates}/$self->{language_code}/invoice.tex : $!"); 1252 open(OUT, ">$self->{tmpfile}") or $self->error("$self->{tmpfile} : $!"); 1253 1254 my @h = (); 1255 1256 while (<HDR>) { 1257 if ($_ =~ /<%include /) { 1258 s/<%include //; 1259 s/%>//; 1260 open(INC, "$templates/$myconfig->{templates}/$self->{language_code}/$_") or $self->error("$templates/$myconfig->{templates}/$self->{language_code}/$_ : $!"); 1261 push @h, <INC>; 1262 close(INC); 1263 next; 1264 } 1265 last if $_ =~ /begin\{document\}/; 1266 push @h, $_; 1267 } 1268 1269 push @h, q| 1270\usepackage{longtable} 1271 1272\begin{document} 1273 1274|; 1275 1276 while (<HDR>) { 1277 if ($_ =~ /fontfamily/) { 1278 push @h, $_; 1279 last; 1280 } 1281 } 1282 close(HDR); 1283 1284 print OUT @h; 1285 1286 $self->format_string(qw(title company)); 1287 1288 print OUT qq|\\centerline\{\\textbf\{$self->{title} / $self->{company}\}\}\n|; 1289 1290 $self->{option} =~ s/<br>/ 1291/g; 1292 print OUT $self->format_string((option)).qq|\n\n|; 1293 1294 1295 my $l = $#{$self->{$column->[0]}}; 1296 1297 my $p = 1; 1298 for (@{$column}) { 1299 if ($hdr->{$_}{align} eq 'p') { 1300 $p++; 1301 } 1302 } 1303 1304 my $line; 1305 1306 $line = q|\begin{longtable}[l]{|; 1307 1308 for (@{$column}) { 1309 $line .= qq|$hdr->{$_}{align}|; 1310 if ($hdr->{$_}{align} eq 'p') { 1311 if ($hdr->{$_}{width}) { 1312 $line .= q|{|.$hdr->{$_}{width}.q|\linewidth}|; 1313 } else { 1314 $line .= q|{|.$self->round_amount(1/$p,2).q|\linewidth}|; 1315 } 1316 } 1317 } 1318 $line .= q|} 1319|; 1320 1321 print OUT $line; 1322 1323 $line = ""; 1324 for (@{$column}) { 1325 $self->{temp} = $hdr->{$_}{label}; 1326 $self->format_string((temp)); 1327 $line .= qq|\\textbf{$self->{temp}} \& |; 1328 } 1329 $line = substr($line, 0, -3) .q| \\\\ \hline|; 1330 1331 print OUT qq|$line\n\\endfirsthead\n|; 1332 print OUT qq|$line\n\\endhead\n|; 1333 1334 print OUT qq|\\hline\n\\endfoot\n|; 1335 print OUT qq|\\hline\n\\endlastfoot\n|; 1336 1337 for my $i (0 .. $l) { 1338 $line = ""; 1339 for (@{$column}) { 1340 $self->{temp} = $self->{$_}[$i]; 1341 if ($self->{temp} && $hdr->{$_}{type} ne 'n') { 1342 $self->format_string(temp) unless $hdr->{$_}{image}; 1343 } 1344 $line .= qq|$self->{temp} \& |; 1345 } 1346 print OUT substr($line, 0, -3) .qq| \\\\ \n|; 1347 } 1348 1349 print OUT q|\end{longtable} 1350\end{document} 1351|; 1352 1353 close(OUT); 1354 1355 $self->run_latex($userspath, $dvipdf, $xelatex); 1356 1357 $self->process_tex($self->{OUT}); 1358 1359 $self->cleanup; 1360 1361} 1362 1363 1364sub process_tex { 1365 my ($self, $out) = @_; 1366 1367 my $err; 1368 1369 $self->{OUT} = $out; 1370 unless (open(IN, $self->{tmpfile})) { 1371 $err = $!; 1372 $self->cleanup; 1373 $self->error("$self->{tmpfile} : $err"); 1374 } 1375 1376 binmode(IN); 1377 1378 chdir("$self->{cwd}"); 1379 1380 if ($self->{OUT}) { 1381 unless (open(OUT, $self->{OUT})) { 1382 $err = $!; 1383 $self->cleanup; 1384 $self->error("$self->{OUT} : $err"); 1385 } 1386 } else { 1387 1388 # launch application 1389 print qq|Content-Type: application/$self->{format} 1390Content-Disposition: inline; filename=$self->{tmpfile}\n\n|; 1391 1392 unless (open(OUT, ">-")) { 1393 $err = $!; 1394 $self->cleanup; 1395 $self->error("STDOUT : $err"); 1396 } 1397 1398 } 1399 1400 binmode(OUT); 1401 1402 while (<IN>) { 1403 print OUT $_; 1404 } 1405 1406 close(IN); 1407 close(OUT); 1408 1409} 1410 1411 1412sub format_line { 1413 my $self = shift; 1414 1415 $_ = shift; 1416 my $i = shift; 1417 1418 my $j; 1419 my $str; 1420 my $newstr; 1421 my $pos; 1422 my $l; 1423 my $lf; 1424 my $line; 1425 my $var = ""; 1426 my %kw; 1427 my @kw; 1428 my $offset; 1429 my $pad; 1430 my $item; 1431 my $key; 1432 my $value; 1433 1434 while (/<%(.+?)%>/) { 1435 1436 $var = $1; 1437 $newstr = ""; 1438 1439 %kw = (); 1440 if ($var =~ /(align|width|offset|group)\s*?=/) { 1441 @kw = split / /, $var; 1442 $var = $kw[0]; 1443 foreach $item (@kw) { 1444 ($key, $value) = split /=/, $item; 1445 if ($value ne "") { 1446 $kw{$key} = $value; 1447 } 1448 } 1449 } 1450 1451 if ($var =~ /\s/) { 1452 $str = ""; 1453 @kw = split / /, $var, 3; 1454 if ($var =~ /^if\s+?not /) { 1455 $kw[1] = $kw[2]; 1456 pop @kw; 1457 } 1458 1459 if ($#kw == 2) { 1460 for $j (0 .. 2) { 1461 $item = $kw[$j]; 1462 if ($item !~ /'/) { 1463 if (defined $i) { 1464 if (exists $self->{$item}[$i]) { 1465 $kw[$j] = qq|'$self->{$item}[$i]'|; 1466 } 1467 } else { 1468 if (exists $self->{$item}) { 1469 $kw[$j] = qq|'$self->{$item}'|; 1470 } 1471 } 1472 } 1473 } 1474 $str = eval qq|$kw[0] $kw[1] $kw[2]|; 1475 } else { 1476 if (defined $i) { 1477 $str = $self->{$kw[1]}[$i]; 1478 } else { 1479 $str = $self->{$kw[1]}; 1480 } 1481 } 1482 } else { 1483 if (defined $i) { 1484 $str = $self->{$var}[$i]; 1485 } else { 1486 $str = $self->{$var}; 1487 } 1488 } 1489 $newstr = $str; 1490 1491 if ($var =~ /^if\s+?not /) { 1492 if ($str) { 1493 $var =~ s/if\s+?not\s+?//; 1494 s/<%if\s+?not\s+?$var%>.*?(<%end\s+?$var%>|$)//s; 1495 } else { 1496 s/<%$var%>//; 1497 } 1498 next; 1499 } 1500 1501 if ($var =~ /^if /) { 1502 if ($str) { 1503 s/<%$var%>//; 1504 } else { 1505 $var =~ s/if\s+?//; 1506 s/<%if\s+?$var%>.*?(<%(end|else)\s+?$var%>|$)//s; 1507 } 1508 next; 1509 } 1510 1511 if ($var =~ /^else /) { 1512 if ($str) { 1513 $var =~ s/else\s+?//; 1514 s/<%else\s+?$var%>.*?(<%end\s+?$var%>|$)//s; 1515 } else { 1516 s/<%$var%>//; 1517 } 1518 next; 1519 } 1520 1521 if ($var =~ /^end /) { 1522 s/<%$var%>//; 1523 next; 1524 } 1525 1526 if ($kw{align} || $kw{width} || $kw{offset}) { 1527 1528 $newstr = ""; 1529 $offset = 0; 1530 $lf = ""; 1531 1532 chomp $str; 1533 $str .= "\n"; 1534 1535 foreach $str (split /\n/, $str) { 1536 1537 $line = $str; 1538 $l = length $str; 1539 1540 do { 1541 if (($pos = length $str) > $kw{width}) { 1542 if (($pos = rindex $str, " ", $kw{width}) > 0) { 1543 $line = substr($str, 0, $pos); 1544 } 1545 $pos = length $str if $pos == -1; 1546 } 1547 1548 $l = length $line; 1549 1550 # pad left, right or center 1551 $l = ($kw{width} - $l); 1552 1553 $pad = " " x $l; 1554 1555 if ($kw{align} =~ /right/i) { 1556 $line = " " x $offset . $pad . $line; 1557 } 1558 1559 if ($kw{align} =~ /left/i) { 1560 $line = " " x $offset . $line . $pad; 1561 } 1562 1563 if ($kw{align} =~ /center/i) { 1564 $pad = " " x ($l/2); 1565 $line = " " x $offset . $pad . $line; 1566 $pad = " " x ($l/2); 1567 $line .= $pad; 1568 } 1569 1570 $newstr .= "$lf$line"; 1571 1572 $str = substr($str, $pos + 1); 1573 $line = $str; 1574 $lf = "\n"; 1575 1576 $offset = $kw{offset}; 1577 1578 } while ($str); 1579 } 1580 } 1581 1582 if ($kw{group}) { 1583 1584 $kw{group} =~ s/\d+//; 1585 $n = $&; 1586 @kw = split //, $str; 1587 1588 if ($kw{group} =~ /right/i) { 1589 @kw = reverse @kw; 1590 } 1591 1592 $j = $n - 1; 1593 $newstr = ""; 1594 foreach $str (@kw) { 1595 $j++; 1596 if (! ($j % $n)) { 1597 $newstr .= " "; 1598 } 1599 $newstr .= $str; 1600 } 1601 $newstr = substr($newstr,1); 1602 1603 if ($kw{group} =~ /right/i) { 1604 $newstr = reverse split //, $newstr; 1605 } 1606 } 1607 1608 if ($kw{ASCII}) { 1609 my $carret; 1610 my $nn; 1611 $n = 0; 1612 if ($kw{ASCII} =~ /^\^/) { 1613 $carret = '^'; 1614 } 1615 if ($kw{ASCII} =~ /\d+/) { 1616 $n = length $&; 1617 $nn = $&; 1618 } 1619 1620 $newstr = ""; 1621 for (split //, $str) { 1622 $newstr .= "$carret"; 1623 if ($n) { 1624 $newstr .= substr($nn . ord, -$n); 1625 } else { 1626 $newstr .= ord; 1627 } 1628 } 1629 } 1630 1631 s/<%(.+?)%>/$newstr/; 1632 1633 } 1634 1635 $_; 1636 1637} 1638 1639 1640sub format_dcn { 1641 my $self = shift; 1642 1643 $_ = shift; 1644 1645 my $str; 1646 my $modulo; 1647 my $var; 1648 my $padl; 1649 my $param; 1650 1651 my @m = (0, 9, 4, 6, 8, 2, 7, 1, 3, 5); 1652 my %m; 1653 my $m; 1654 my $e; 1655 my @e; 1656 my $i; 1657 1658 my $d; 1659 my @n; 1660 my $n; 1661 my $w; 1662 my $cd; 1663 1664 for (0 .. $#m) { 1665 @{ $m{$_} } = @m; 1666 $m = shift @m; 1667 push @m, $m; 1668 } 1669 1670 if (/<%/) { 1671 1672 while (/<%(.+?)%>/) { 1673 1674 $param = $1; 1675 $str = $param; 1676 1677 ($var, $padl) = split / /, $param; 1678 $padl *= 1; 1679 1680 if ($var eq 'membernumber') { 1681 1682 $str = $self->{$var}; 1683 $str =~ s/\W//g; 1684 $str = substr('0' x $padl . $str, -$padl) if $padl; 1685 1686 } elsif ($var =~ /modulo/) { 1687 1688 $str = qq|\x01$str\x01|; 1689 1690 } else { 1691 $i = 0; 1692 $str = $self->{$var}; 1693 $str =~ s/\D/++$i/ge; 1694 $str = substr('0' x $padl . $str, -$padl) if $padl; 1695 } 1696 1697 s/<%$param%>/$str/; 1698 1699 } 1700 1701 /(.+?)\x01modulo/; 1702 $modulo = $1; 1703 1704 while (/\x01(modulo.+?)\x01/) { 1705 1706 $param = $1; 1707 1708 @e = split //, $modulo; 1709 1710 if ($param eq 'modulo10') { 1711 $e = 0; 1712 1713 for $n (@e) { 1714 $e = $m{$e}[$n]; 1715 } 1716 $str = substr(10 - $e, -1); 1717 } 1718 1719 if ($param =~ /modulo(1\d+)+?_/) { 1720 ($n, $w, $lr) = split /_/, $param; 1721 $cd = 0; 1722 $m = $1; 1723 1724 if ($lr eq 'right') { 1725 @e = reverse @e; 1726 } 1727 1728 if ($w eq '12' || $w eq '21') { 1729 @n = split //, $w; 1730 1731 for $i (0 .. $#e) { 1732 $n = $i % 2; 1733 if (($d = $e[$i] * $n[$n]) > 9) { 1734 for $n (split //, $d) { 1735 $cd += $n; 1736 } 1737 } else { 1738 $cd += $d; 1739 } 1740 } 1741 } else { 1742 @n = split //, $w; 1743 for $i (0 .. $#e) { 1744 $n = $i % 2; 1745 $cd += $e[$i] * $n[$n]; 1746 } 1747 } 1748 $str = $cd % $m; 1749 if ($m eq '10') { 1750 if ($str > 0) { 1751 $str = $m - $str; 1752 } 1753 } 1754 } 1755 1756 s/\x01$param\x01/$str/; 1757 1758 /(.+?)\x01modulo/; 1759 $modulo = $1; 1760 1761 } 1762 1763 } 1764 1765 $_; 1766 1767} 1768 1769 1770sub cleanup { 1771 my $self = shift; 1772 1773 chdir("$self->{tmpdir}"); 1774 1775 my @err = (); 1776 if (-f "$self->{errfile}") { 1777 open(FH, "$self->{errfile}"); 1778 @err = <FH>; 1779 close(FH); 1780 } 1781 1782 if ($self->{tmpfile}) { 1783 # strip extension 1784 $self->{tmpfile} =~ s/\.\w+$//g; 1785 my $tmpfile = $self->{tmpfile}; 1786 unlink(<$tmpfile.*>); 1787 } 1788 1789 chdir("$self->{cwd}"); 1790 1791 "@err"; 1792 1793} 1794 1795 1796sub rerun_latex { 1797 my $self = shift; 1798 1799 my $w = 0; 1800 if (-f "$self->{errfile}") { 1801 open(FH, "$self->{errfile}"); 1802 $w = grep /(longtable Warning:|Warning:.*?LastPage)/, <FH>; 1803 close(FH); 1804 } 1805 1806 $w; 1807 1808} 1809 1810 1811sub format_string { 1812 my ($self, @fields) = @_; 1813 1814 my $format = $self->{format}; 1815 if ($self->{format} =~ /(ps|pdf)/) { 1816 $format = ($self->{charset} =~ /utf/i) ? 'utf' : 'tex'; 1817 } 1818 1819 my %replace = ( 'order' => { html => [ '<', '>', '\n', '\r' ], 1820 txt => [ '\n', '\r' ], 1821 tex => [ quotemeta('\\'), '&', '\n', 1822 '\r', '\$', '%', '_', '#', 1823 quotemeta('^'), '{', '}', '<', '>', 1824 '£' ], 1825 utf => [ quotemeta('\\'), '&', '\n', 1826 '\r', '\$', '%', '_', '#', 1827 quotemeta('^'), '{', '}', '<', '>'] 1828 }, 1829 html => { '<' => '<', '>' => '>', 1830 '\n' => '<br>', '\r' => '<br>' 1831 }, 1832 txt => { '\n' => "\n", '\r' => "\r" }, 1833 tex => { '&' => '\&', '\$' => '\$', '%' => '\%', 1834 '_' => '\_', '#' => '\#', 1835 quotemeta('^') => '\^\\', '{' => '\{', 1836 '}' => '\}', '<' => '$<$', '>' => '$>$', 1837 '\n' => '\newline ', '\r' => '\newline ', 1838 '£' => '\pounds ', quotemeta('\\') => '/' 1839 } 1840 ); 1841 1842 $replace{utf} = $replace{tex}; 1843 1844 my $key; 1845 foreach $key (@{ $replace{order}{$format} }) { 1846 for (@fields) { $self->{$_} =~ s/$key/$replace{$format}{$key}/g } 1847 } 1848 1849} 1850 1851 1852sub pad { 1853 my ($self, $str, $chr, $align, $width, $display) = @_; 1854 1855 $chr =~ s/-(-|\+)??\d+(s|S)?//; 1856 $chr = " " if $chr eq ""; 1857 if ($display) { 1858 $width ||= length $str; 1859 $chr = "\x01" if $chr eq " "; 1860 } 1861 1862 $align ||= 'left'; 1863 1864 if (! $display && ($self->{filetype} ne 'txt')) { 1865 if ($chr =~ /\s+/) { 1866 $chr = ""; 1867 $width = length $str; 1868 } 1869 } 1870 1871 my $fill = "$chr" x $width; 1872 1873 if ($align eq 'right') { 1874 $str = substr("$fill$str", -($width)); 1875 } 1876 1877 if ($align eq 'left') { 1878 $str = substr("$str$fill", 0, $width); 1879 } 1880 1881 if ($align eq 'center') { 1882 $fill = "$chr" x ($width/2); 1883 $str = substr("$fill$str$fill", 0, $width); 1884 } 1885 1886 $str =~ s/\x01/ /g if $display; 1887 1888 $str; 1889 1890} 1891 1892 1893sub datediff { 1894 my ($self, $myconfig, $date1, $date2) = @_; 1895 1896 use Time::Local; 1897 1898 my ($yy1, $mm1, $dd1); 1899 my ($yy2, $mm2, $dd2); 1900 1901 if ($date1 && $date2) { 1902 1903 if (($date1 =~ /\D/) && ($date2 =~ /\D/)) { 1904 1905 if ($myconfig->{dateformat} =~ /^yy/) { 1906 ($yy1, $mm1, $dd1) = split /\D/, $date1; 1907 ($yy2, $mm2, $dd2) = split /\D/, $date2; 1908 } 1909 if ($myconfig->{dateformat} =~ /^mm/) { 1910 ($mm1, $dd1, $yy1) = split /\D/, $date1; 1911 ($mm2, $dd2, $yy2) = split /\D/, $date2; 1912 } 1913 if ($myconfig->{dateformat} =~ /^dd/) { 1914 ($dd1, $mm1, $yy1) = split /\D/, $date1; 1915 ($dd2, $mm2, $yy2) = split /\D/, $date2; 1916 } 1917 1918 $yy1 += 2000 if length $yy1 == 2; 1919 $yy2 += 2000 if length $yy2 == 2; 1920 1921 } else { 1922 # ISO 1923 $date1 =~ /(....)(..)(..)/; 1924 $yy1 = $1; 1925 $mm1 = $2; 1926 $dd1 = $3; 1927 1928 $date2 =~ /(....)(..)(..)/; 1929 $yy2 = $1; 1930 $mm2 = $2; 1931 $dd2 = $3; 1932 1933 } 1934 } 1935 1936 $dd1 *= 1; 1937 $dd2 *= 1; 1938 $mm1--; 1939 $mm2--; 1940 $mm1 *= 1; 1941 $mm2 *= 1; 1942 1943 if ($dd1 && $dd2) { 1944 sprintf("%.0f", (timelocal(0,0,12,$dd2,$mm2,$yy2) - timelocal(0,0,12,$dd1,$mm1,$yy1))/86400); 1945 } 1946 1947} 1948 1949 1950sub datetonum { 1951 my ($self, $myconfig, $date) = @_; 1952 1953 my ($mm, $dd, $yy); 1954 1955 if ($date && $date =~ /\D/) { 1956 1957 if ($myconfig->{dateformat} =~ /^yy/) { 1958 ($yy, $mm, $dd) = split /\D/, $date; 1959 } 1960 if ($myconfig->{dateformat} =~ /^mm/) { 1961 ($mm, $dd, $yy) = split /\D/, $date; 1962 } 1963 if ($myconfig->{dateformat} =~ /^dd/) { 1964 ($dd, $mm, $yy) = split /\D/, $date; 1965 } 1966 1967 $dd *= 1; 1968 $mm *= 1; 1969 $yy += 2000 if length $yy == 2; 1970 1971 $dd = substr("0$dd", -2); 1972 $mm = substr("0$mm", -2); 1973 1974 $date = "$yy$mm$dd"; 1975 } 1976 1977 $date; 1978 1979} 1980 1981 1982sub add_date { 1983 my ($self, $myconfig, $date, $repeat, $unit) = @_; 1984 1985 use Time::Local; 1986 1987 my $diff = 0; 1988 my $spc = $myconfig->{dateformat}; 1989 $spc =~ s/\w//g; 1990 $spc = substr($spc, 0, 1); 1991 1992 if ($date) { 1993 if ($date =~ /\D/) { 1994 1995 if ($myconfig->{dateformat} =~ /^yy/) { 1996 ($yy, $mm, $dd) = split /\D/, $date; 1997 } 1998 if ($myconfig->{dateformat} =~ /^mm/) { 1999 ($mm, $dd, $yy) = split /\D/, $date; 2000 } 2001 if ($myconfig->{dateformat} =~ /^dd/) { 2002 ($dd, $mm, $yy) = split /\D/, $date; 2003 } 2004 2005 } else { 2006 # ISO 2007 $date =~ /(....)(..)(..)/; 2008 $yy = $1; 2009 $mm = $2; 2010 $dd = $3; 2011 } 2012 2013 if ($unit =~ /day/i) { 2014 $diff = $repeat * 86400; 2015 } 2016 if ($unit =~ /week/i) { 2017 $diff = $repeat * 604800; 2018 } 2019 if ($unit =~ /month/i) { 2020 my $m = 0; 2021 my @days = ( 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ); 2022 my @d; 2023 2024 if (($yy % 4)) { 2025 @days = ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ); 2026 } 2027 2028 if ($repeat < 0) { 2029 if ($dd < $days[$mm-1]) { 2030 @d = splice(@days,0,$mm - 1); 2031 } else { 2032 @d = splice(@days,0,$mm); 2033 } 2034 } else { 2035 @d = splice(@days,0,$mm - 1); 2036 } 2037 push(@days, @d); 2038 if ($repeat < 0) { 2039 @days = reverse @days; 2040 } 2041 2042 for (1 .. abs($repeat)) { 2043 $diff += $days[$m] * 86400; 2044 $m++; 2045 } 2046 $diff *= -1 if $repeat < 0; 2047 } 2048 if ($unit =~ /year/i) { 2049 $yy += $repeat; 2050 $dd = 29 if (!($yy % 4) && ($dd eq '28') && ($mm eq '02')); 2051 $dd = 28 if (($yy % 4) && ($dd eq '29') && ($mm eq '02')); 2052 } 2053 2054 $mm--; 2055 2056 @t = localtime(timelocal(0,0,12,$dd,$mm,$yy) + $diff); 2057 2058 $t[4]++; 2059 $mm = substr("0$t[4]",-2); 2060 $dd = substr("0$t[3]",-2); 2061 $yy = $t[5] + 1900; 2062 2063 if ($date =~ /\D/) { 2064 2065 if ($myconfig->{dateformat} =~ /^yy/) { 2066 $date = "$yy$spc$mm$spc$dd"; 2067 } 2068 if ($myconfig->{dateformat} =~ /^mm/) { 2069 $date = "$mm$spc$dd$spc$yy"; 2070 } 2071 if ($myconfig->{dateformat} =~ /^dd/) { 2072 $date = "$dd$spc$mm$spc$yy"; 2073 } 2074 2075 } else { 2076 $date = "$yy$mm$dd"; 2077 } 2078 } 2079 2080 $date; 2081 2082} 2083 2084 2085sub format_date { 2086 my ($self, $dateformat, $date) = @_; 2087 2088 my $spc = $dateformat; 2089 $spc =~ s/\w//g; 2090 $spc = substr($spc, 0, 1); 2091 2092 # ISO 2093 $date =~ /(....)(..)(..)/; 2094 $yy = $1; 2095 $mm = $2; 2096 $dd = $3; 2097 2098 if ($dateformat !~ /yyyy/) { 2099 $yy = substr($yy, -2); 2100 } 2101 2102 if ($dateformat =~ /^yy/) { 2103 $date = "$yy$spc$mm$spc$dd"; 2104 } 2105 if ($dateformat =~ /^mm/) { 2106 $date = "$mm$spc$dd$spc$yy"; 2107 } 2108 if ($dateformat =~ /^dd/) { 2109 $date = "$dd$spc$mm$spc$yy"; 2110 } 2111 2112 $date; 2113 2114} 2115 2116 2117sub valid_date { 2118 my ($self, $myconfig, $date) = @_; 2119 2120 my %dd = ( '01' => 31, '02' => 28, '03' => 31, '04' => 30, 2121 '05' => 31, '06' => 30, '07' => 31, '08' => 31, 2122 '09' => 30, '10' => 31, '11' => 30, '12' => 31 ); 2123 2124 if ($date) { 2125 $date = $self->datetonum($myconfig, $date); 2126 2127 if ((length $date) != 8) { 2128 return; 2129 } 2130 2131 my ($yy,$mm,$dd) = $date =~ /(....)(..)(..)/; 2132 2133 if ($yy % 400) { 2134 $dd{'02'} = 29 unless ($yy % 4); 2135 } 2136 2137 if ($mm < 1 || $mm > 12 || $dd > $dd{$mm}) { 2138 return; 2139 } 2140 } 2141 2142 1; 2143 2144} 2145 2146 2147sub print_button { 2148 my ($self, $button) = @_; 2149 2150 for (sort { $button->{$a}->{ndx} <=> $button->{$b}->{ndx} } keys %{$button}) { 2151 print qq|<input class=submit type=submit name=action value="$button->{$_}{value}" accesskey="$button->{$_}{key}" title="$button->{$_}{value} [$button->{$_}{key}]">\n|; 2152 } 2153 2154} 2155 2156 2157# Database routines used throughout 2158 2159sub dbconnect { 2160 my ($self, $myconfig) = @_; 2161 2162 # connect to database 2163 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, {AutoCommit => 1}) or $self->dberror; 2164 2165 # set db options 2166 if ($myconfig->{dboptions}) { 2167 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions}); 2168 } 2169 2170 $dbh; 2171 2172} 2173 2174 2175sub dbconnect_noauto { 2176 my ($self, $myconfig) = @_; 2177 2178 # connect to database 2179 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, {AutoCommit => 0}) or $self->dberror; 2180 2181 # set db options 2182 if ($myconfig->{dboptions}) { 2183 $dbh->do($myconfig->{dboptions}); 2184 } 2185 2186 $dbh; 2187 2188} 2189 2190 2191sub dbquote { 2192 my ($self, $var, $type) = @_; 2193 2194 $var =~ s/;/\\;/g; 2195 2196 # DBI does not return NULL for SQL_DATE if the date is empty 2197 if ($type eq 'SQL_DATE') { 2198 $_ = ($var) ? "'$var'" : "NULL"; 2199 } 2200 if ($type eq 'SQL_INT') { 2201 $_ = ($var eq "") ? "NULL" : $var * 1; 2202 } 2203 2204 $_; 2205 2206} 2207 2208 2209sub update_balance { 2210 my ($self, $dbh, $table, $field, $where, $value) = @_; 2211 2212 # if we have a value, go do it 2213 if ($value) { 2214 # retrieve balance from table 2215 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE"; 2216 my ($balance) = $dbh->selectrow_array($query); 2217 2218 $balance += $value; 2219 # update balance 2220 $query = "UPDATE $table SET $field = $balance WHERE $where"; 2221 $dbh->do($query) || $self->dberror($query); 2222 } 2223 2224} 2225 2226 2227sub update_exchangerate { 2228 my ($self, $dbh, $curr, $transdate, $exchangerate) = @_; 2229 2230 # some sanity check for currency 2231 return if (! $curr || $self->{currency} eq $self->{defaultcurrency}); 2232 2233 my $query = qq|SELECT curr FROM exchangerate 2234 WHERE curr = '$curr' 2235 AND transdate = '$transdate' 2236 FOR UPDATE|; 2237 my $sth = $dbh->prepare($query); 2238 $sth->execute || $self->dberror($query); 2239 2240 $exchangerate *= 1; 2241 2242 if ($sth->fetchrow_array) { 2243 $query = qq|UPDATE exchangerate 2244 SET exchangerate = $exchangerate 2245 WHERE curr = '$curr' 2246 AND transdate = '$transdate'|; 2247 } else { 2248 $query = qq|INSERT INTO exchangerate (curr, exchangerate, transdate) 2249 VALUES ('$curr', $exchangerate, '$transdate')|; 2250 } 2251 $sth->finish; 2252 2253 $dbh->do($query) || $self->dberror($query); 2254 2255} 2256 2257 2258sub save_exchangerate { 2259 my ($self, $myconfig, $currency, $transdate, $exchangerate) = @_; 2260 2261 my $dbh = $self->dbconnect($myconfig); 2262 2263 $self->update_exchangerate($dbh, $currency, $transdate, $exchangerate); 2264 2265 $dbh->disconnect; 2266 2267} 2268 2269 2270sub get_exchangerate { 2271 my ($self, $myconfig, $dbh, $curr, $transdate) = @_; 2272 2273 my $disconnect; 2274 2275 if (! $dbh) { 2276 $dbh = $self->dbconnect($myconfig); 2277 $disconnect = 1; 2278 } 2279 2280 my $exchangerate; 2281 2282 if ($transdate) { 2283 my $query = qq|SELECT exchangerate FROM exchangerate 2284 WHERE curr = '$curr' 2285 AND transdate = '$transdate'|; 2286 ($exchangerate) = $dbh->selectrow_array($query); 2287 } 2288 2289 $dbh->disconnect if $disconnect; 2290 2291 $exchangerate; 2292 2293} 2294 2295 2296sub check_exchangerate { 2297 my ($self, $myconfig, $currency, $transdate) = @_; 2298 2299 return "" if ! $transdate || $self->{defaultcurrency} eq $currency; 2300 2301 my $dbh = $self->dbconnect($myconfig); 2302 2303 my $query; 2304 my $exchangerate; 2305 2306 $query = qq|SELECT exchangerate FROM exchangerate 2307 WHERE curr = '$currency' 2308 AND transdate = |.$self->dbquote($transdate, SQL_DATE); 2309 ($exchangerate) = $dbh->selectrow_array($query); 2310 2311 $query = qq|SELECT prec FROM curr 2312 WHERE curr = '$currency'|; 2313 ($self->{precision}) = $dbh->selectrow_array($query); 2314 2315 $dbh->disconnect; 2316 2317 $exchangerate; 2318 2319} 2320 2321 2322sub exchangerate_defaults { 2323 my ($self, $dbh, $myconfig, $form) = @_; 2324 2325 my $var; 2326 my $query; 2327 2328 # get default currencies 2329 $self->{currencies} = $self->get_currencies($myconfig, $dbh); 2330 $self->{defaultcurrency} = substr($self->{currencies},0,3); 2331 2332 $query = qq|SELECT exchangerate 2333 FROM exchangerate 2334 WHERE curr = ? 2335 AND transdate = ?|; 2336 my $eth1 = $dbh->prepare($query) || $self->dberror($query); 2337 2338 $query = qq~SELECT max(transdate || ' ' || exchangerate || ' ' || curr) 2339 FROM exchangerate 2340 WHERE curr = ?~; 2341 my $eth2 = $dbh->prepare($query) || $self->dberror($query); 2342 2343 # get exchange rates for transdate or max 2344 foreach $var (split /:/, substr($self->{currencies},4)) { 2345 $eth1->execute($var, $self->{transdate}); 2346 ($self->{$var}) = $eth1->fetchrow_array; 2347 if (! $self->{$var} ) { 2348 $eth2->execute($var); 2349 2350 ($self->{$var}) = $eth2->fetchrow_array; 2351 (undef, $self->{$var}) = split / /, $self->{$var}; 2352 $self->{$var} = 1 unless $self->{$var}; 2353 $eth2->finish; 2354 } 2355 $eth1->finish; 2356 } 2357 2358 $self->{$self->{currency}} = $self->{exchangerate} || 1; 2359 $self->{$self->{defaultcurrency}} = 1; 2360 2361} 2362 2363 2364sub add_shipto { 2365 my ($self, $dbh, $id) = @_; 2366 2367 my $shipto; 2368 foreach my $item (qw(name address1 address2 city state zipcode country contact phone fax email)) { 2369 if ($self->{"shipto$item"} ne "") { 2370 if ($self->{$item} ne $self->{"shipto$item"}) { 2371 $shipto = 1; 2372 last; 2373 } 2374 } 2375 } 2376 2377 if ($shipto) { 2378 $self->{shiptorecurring} *= 1; 2379 my $query = qq|INSERT INTO shipto (trans_id, shiptoname, shiptoaddress1, 2380 shiptoaddress2, shiptocity, shiptostate, 2381 shiptozipcode, shiptocountry, shiptocontact, 2382 shiptophone, shiptofax, shiptoemail, shiptorecurring) 2383 VALUES ($id, | 2384 .$dbh->quote($self->{shiptoname}).qq|, | 2385 .$dbh->quote($self->{shiptoaddress1}).qq|, | 2386 .$dbh->quote($self->{shiptoaddress2}).qq|, | 2387 .$dbh->quote($self->{shiptocity}).qq|, | 2388 .$dbh->quote($self->{shiptostate}).qq|, | 2389 .$dbh->quote($self->{shiptozipcode}).qq|, | 2390 .$dbh->quote($self->{shiptocountry}).qq|, | 2391 .$dbh->quote($self->{shiptocontact}).qq|, 2392 '$self->{shiptophone}', '$self->{shiptofax}', 2393 '$self->{shiptoemail}', '$self->{shiptorecurring}')|; 2394 $dbh->do($query) || $self->dberror($query); 2395 } 2396 2397} 2398 2399 2400sub reset_shipped { 2401 my ($self, $dbh, $id, $ml) = @_; 2402 2403 my $query = qq|SELECT o.parts_id, o.ship, p.inventory_accno_id, 2404 p.income_accno_id, p.expense_accno_id, p.assembly 2405 FROM orderitems o 2406 JOIN parts p ON (p.id = o.parts_id) 2407 WHERE trans_id = $id|; 2408 2409 my $sth = $dbh->prepare($query) || $self->dberror($query); 2410 my $ref; 2411 2412 $query = qq|SELECT p.id, p.inventory_accno_id, a.qty 2413 FROM assembly a 2414 JOIN parts p ON (p.id = a.parts_id) 2415 WHERE a.aid = ?|; 2416 my $kth = $dbh->prepare($query) || $self->dberror($query); 2417 my $kref; 2418 2419 $sth->execute; 2420 2421 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 2422 if ($ref->{inventory_accno_id} || $ref->{assembly}) { 2423 $self->update_balance($dbh, 2424 "parts", 2425 "onhand", 2426 qq|id = $ref->{parts_id}|, 2427 $ref->{ship} * $ml); 2428 } 2429 2430 unless ($ref->{inventory_accno_id} + $ref->{income_accno_id} + $ref->{expense_accno_id}) { 2431 $kth->execute($ref->{parts_id}); 2432 2433 while ($kref = $kth->fetchrow_hashref(NAME_lc)) { 2434 if ($kref->{inventory_accno_id}) { 2435 $self->update_balance($dbh, 2436 "parts", 2437 "onhand", 2438 qq|id = $kref->{id}|, 2439 $kref->{qty} * $ref->{ship} * $ml); 2440 } 2441 } 2442 $kth->finish; 2443 } 2444 } 2445 $sth->finish; 2446 2447} 2448 2449 2450sub get_employee { 2451 my ($self, $dbh) = @_; 2452 2453 my $login = $self->{login}; 2454 $login =~ s/@.*//; 2455 my $query = qq|SELECT name, id FROM employee 2456 WHERE login = '$login'|; 2457 my (@name) = $dbh->selectrow_array($query); 2458 $name[1] *= 1; 2459 2460 @name; 2461 2462} 2463 2464 2465# this sub gets the id and name from $table 2466sub get_name { 2467 my ($self, $myconfig, $table, $transdate) = @_; 2468 2469 # connect to database 2470 my $dbh = $self->dbconnect($myconfig); 2471 2472 my $where = "1=1"; 2473 if ($transdate) { 2474 $where .= qq| AND (ct.startdate IS NULL OR ct.startdate <= '$transdate') 2475 AND (ct.enddate IS NULL OR ct.enddate >= '$transdate')|; 2476 } else { 2477 $where .= qq| AND ct.enddate IS NULL|; 2478 } 2479 2480 my %defaults = $self->get_defaults($dbh, \@{['namesbynumber']}); 2481 2482 my $sortorder = "name"; 2483 $sortorder = $self->{searchby} if $self->{searchby}; 2484 2485 my $var; 2486 2487 if ($sortorder eq 'name') { 2488 $var = $self->like(lc $self->{$table}); 2489 $where .= qq| AND lower(ct.name) LIKE '$var'|; 2490 } else { 2491 $var = $self->like(lc $self->{"${table}number"}); 2492 $where .= qq| AND lower(ct.${table}number) LIKE '$var'|; 2493 } 2494 2495 if ($defaults{namesbynumber}) { 2496 $sortorder = "${table}number"; 2497 } 2498 2499 my $query = qq|SELECT ct.*, 2500 ad.address1, ad.address2, ad.city, ad.state, 2501 ad.zipcode, ad.country 2502 FROM $table ct 2503 JOIN address ad ON (ad.trans_id = ct.id) 2504 WHERE $where 2505 ORDER BY ct.$sortorder|; 2506 2507 my $sth = $dbh->prepare($query); 2508 2509 $sth->execute || $self->dberror($query); 2510 2511 my $i = 0; 2512 @{ $self->{name_list} } = (); 2513 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 2514 push(@{ $self->{name_list} }, $ref); 2515 $i++; 2516 } 2517 $sth->finish; 2518 $dbh->disconnect; 2519 2520 $i; 2521 2522} 2523 2524 2525sub get_currencies { 2526 my ($self, $myconfig, $dbh) = @_; 2527 2528 my $disconnect; 2529 2530 if (! $dbh) { 2531 $dbh = $self->dbconnect($myconfig); 2532 $disconnect = 1; 2533 } 2534 2535 my $currencies; 2536 my $curr; 2537 my $precision; 2538 2539 my $query = qq|SELECT curr, prec 2540 FROM curr 2541 ORDER BY rn|; 2542 my $sth = $dbh->prepare($query); 2543 $sth->execute || $self->dberror($query); 2544 2545 while (($curr, $precision) = $sth->fetchrow_array) { 2546 if ($self->{currency} eq $curr) { 2547 $self->{precision} = $precision; 2548 } 2549 $currencies .= "$curr:"; 2550 } 2551 $sth->finish; 2552 2553 $dbh->disconnect if $disconnect; 2554 2555 chop $currencies; 2556 $currencies; 2557 2558} 2559 2560 2561sub get_onhand { 2562 my ($self, $myconfig, $dbh) = @_; 2563 2564 my $disconnect; 2565 2566 if (! $dbh) { 2567 $dbh = $self->dbconnect($myconfig); 2568 $disconnect = 1; 2569 } 2570 2571 my $query; 2572 my $sth; 2573 my $warehouse_id; 2574 (undef, $warehouse_id) = split /--/, $self->{warehouse}; 2575 2576 if ($warehouse_id) { 2577 $query = qq|SELECT SUM(qty) 2578 FROM inventory 2579 WHERE parts_id = ? 2580 AND warehouse_id = $warehouse_id|; 2581 $sth = $dbh->prepare($query) || $self->dberror($query); 2582 } else { 2583 $query = qq|SELECT onhand 2584 FROM parts 2585 WHERE id = ?|; 2586 $sth = $dbh->prepare($query) || $self->dberror($query); 2587 } 2588 2589 for (1 .. $self->{rowcount}) { 2590 $sth->execute($self->{"id_$_"} * 1); 2591 ($self->{"onhand_$_"}) = $sth->fetchrow_array; 2592 $sth->finish; 2593 } 2594 2595 $dbh->disconnect if $disconnect; 2596 2597} 2598 2599 2600sub get_defaults { 2601 my ($self, $dbh, $flds) = @_; 2602 2603 my $query = qq|SELECT * FROM defaults 2604 WHERE fldname LIKE ?|; 2605 my $sth = $dbh->prepare($query); 2606 2607 my %defaults; 2608 2609 if (! @{$flds}) { 2610 @{$flds} = '%'; 2611 } 2612 2613 for (@{$flds}) { 2614 $sth->execute($_); 2615 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) { 2616 $defaults{$ref->{fldname}} = $ref->{fldvalue}; 2617 } 2618 $sth->finish; 2619 } 2620 2621 %defaults; 2622 2623} 2624 2625 2626sub all_vc { 2627 my ($self, $myconfig, $vc, $module, $dbh, $transdate, $job, $openinv, $openord) = @_; 2628 2629 my $ref; 2630 my $disconnect; 2631 2632 if (! $dbh) { 2633 $dbh = $self->dbconnect($myconfig); 2634 $disconnect = 1; 2635 } 2636 my $sth; 2637 2638 my $query; 2639 my $arap = lc $module; 2640 my $joinarap; 2641 my $joinoe; 2642 my $where = "1 = 1"; 2643 2644 if ($openinv) { 2645 $joinarap = "JOIN $arap a ON (a.${vc}_id = vc.id)"; 2646 $where .= " AND a.amount != a.paid"; 2647 } 2648 if ($openord) { 2649 $joinoe = "JOIN oe o ON (o.${vc}_id = vc.id)"; 2650 $where .= " AND o.closed = '0' AND o.quotation = '0'"; 2651 $transdate = ""; 2652 } 2653 if ($transdate) { 2654 $where .= qq| AND (vc.startdate IS NULL OR vc.startdate <= '$transdate') 2655 AND (vc.enddate IS NULL OR vc.enddate >= '$transdate')|; 2656 } 2657 2658 $query .= qq|SELECT count(*) FROM $vc vc 2659 $joinarap 2660 $joinoe 2661 WHERE $where|; 2662 my ($count) = $dbh->selectrow_array($query); 2663 2664 # build selection list 2665 if ($count < $myconfig->{vclimit}) { 2666 $self->{"${vc}_id"} *= 1; 2667 $query = qq|SELECT vc.id, vc.name 2668 FROM $vc vc 2669 $joinarap 2670 $joinoe 2671 WHERE $where 2672 UNION SELECT vc.id, vc.name 2673 FROM $vc vc 2674 WHERE vc.id = $self->{"${vc}_id"} 2675 ORDER BY 2|; 2676 $sth = $dbh->prepare($query); 2677 $sth->execute || $self->dberror($query); 2678 @{ $self->{"all_$vc"} } = (); 2679 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 2680 push @{ $self->{"all_$vc"} }, $ref; 2681 } 2682 $sth->finish; 2683 2684 } 2685 2686 2687 # get self 2688 if (! $self->{employee_id}) { 2689 ($self->{employee}, $self->{employee_id}) = split /--/, $self->{employee}; 2690 ($self->{employee}, $self->{employee_id}) = $self->get_employee($dbh) unless $self->{employee_id}; 2691 } 2692 2693 $self->all_employees($myconfig, $dbh, $transdate, 1); 2694 2695 $self->all_departments($myconfig, $dbh, $vc); 2696 2697 $self->all_warehouses($myconfig, $dbh); 2698 2699 $self->all_projects($myconfig, $dbh, $transdate, $job); 2700 2701 $self->all_languages($myconfig, $dbh); 2702 2703 $self->all_taxaccounts($myconfig, $dbh, $transdate); 2704 2705 $dbh->disconnect if $disconnect; 2706 2707} 2708 2709 2710sub all_languages { 2711 my ($self, $myconfig, $dbh) = @_; 2712 2713 my $disconnect; 2714 2715 if (! $dbh) { 2716 $dbh = $self->dbconnect($myconfig); 2717 $disconnect = 1; 2718 } 2719 my $sth; 2720 my $query; 2721 2722 $query = qq|SELECT * 2723 FROM language 2724 ORDER BY 2|; 2725 $sth = $dbh->prepare($query); 2726 $sth->execute || $self->dberror($query); 2727 2728 $self->{all_language} = (); 2729 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 2730 push @{ $self->{all_language} }, $ref; 2731 } 2732 $sth->finish; 2733 2734 $dbh->disconnect if $disconnect; 2735 2736} 2737 2738 2739sub all_taxaccounts { 2740 my ($self, $myconfig, $dbh, $transdate) = @_; 2741 2742 my $disconnect; 2743 2744 if (! $dbh) { 2745 $dbh = $self->dbconnect($myconfig); 2746 $disconnect = 1; 2747 } 2748 my $sth; 2749 my $query; 2750 my $where; 2751 2752 if ($transdate) { 2753 $where = qq| AND (t.validto >= '$transdate' OR t.validto IS NULL)|; 2754 } 2755 2756 if ($self->{taxaccounts}) { 2757 # rebuild tax rates 2758 $query = qq|SELECT t.rate, t.taxnumber 2759 FROM tax t 2760 JOIN chart c ON (c.id = t.chart_id) 2761 WHERE c.accno = ? 2762 $where 2763 ORDER BY c.accno, t.validto|; 2764 $sth = $dbh->prepare($query) || $self->dberror($query); 2765 2766 foreach my $accno (split / /, $self->{taxaccounts}) { 2767 $sth->execute("$accno"); 2768 ($self->{"${accno}_rate"}, $self->{"${accno}_taxnumber"}) = $sth->fetchrow_array; 2769 $sth->finish; 2770 } 2771 } 2772 2773 $dbh->disconnect if $disconnect; 2774 2775} 2776 2777 2778sub all_employees { 2779 my ($self, $myconfig, $dbh, $transdate, $sales) = @_; 2780 2781 my $disconnect; 2782 2783 if (! $dbh) { 2784 $dbh = $self->dbconnect($myconfig); 2785 $disconnect = 1; 2786 } 2787 2788 # setup employees/sales contacts 2789 my $query = qq|SELECT id, name 2790 FROM employee 2791 WHERE 1 = 1|; 2792 2793 if ($transdate) { 2794 $query .= qq| AND (startdate IS NULL OR startdate <= '$transdate') 2795 AND (enddate IS NULL OR enddate >= '$transdate')|; 2796 } else { 2797 $query .= qq| AND enddate IS NULL|; 2798 } 2799 2800 if ($sales) { 2801 $query .= qq| AND sales = '1'|; 2802 } 2803 2804 $query .= qq| ORDER BY name|; 2805 2806 my $sth = $dbh->prepare($query); 2807 $sth->execute || $self->dberror($query); 2808 2809 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) { 2810 push @{ $self->{all_employee} }, $ref; 2811 } 2812 $sth->finish; 2813 2814 $dbh->disconnect if $disconnect; 2815 2816} 2817 2818 2819 2820sub all_projects { 2821 my ($self, $myconfig, $dbh, $transdate, $job) = @_; 2822 2823 my $disconnect; 2824 2825 if (! $dbh) { 2826 $dbh = $self->dbconnect($myconfig); 2827 $disconnect = 1; 2828 } 2829 2830 my $where = "pr.parts_id = 0 OR pr.parts_id IS NULL"; 2831 2832 $where = qq|pr.parts_id > 0| if $job; 2833 2834 my $query = qq|SELECT * 2835 FROM project pr 2836 WHERE $where|; 2837 2838 if ($self->{language_code}) { 2839 $query = qq|SELECT pr.*, t.description AS translation 2840 FROM project pr 2841 LEFT JOIN translation t ON (t.trans_id = pr.id AND 2842 t.language_code = '$self->{language_code}') 2843 WHERE $where|; 2844 } 2845 2846 if ($transdate) { 2847 $query .= qq| AND (startdate IS NULL OR startdate <= '$transdate') 2848 AND (enddate IS NULL OR enddate >= '$transdate')|; 2849 } 2850 2851 $query .= qq| ORDER BY pr.projectnumber|; 2852 2853 $sth = $dbh->prepare($query); 2854 $sth->execute || $self->dberror($query); 2855 2856 @{ $self->{all_project} } = (); 2857 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 2858 push @{ $self->{all_project} }, $ref; 2859 } 2860 $sth->finish; 2861 2862 $dbh->disconnect if $disconnect; 2863 2864} 2865 2866 2867sub all_departments { 2868 my ($self, $myconfig, $dbh, $vc) = @_; 2869 2870 my $disconnect; 2871 if (! $dbh) { 2872 $dbh = $self->dbconnect($myconfig); 2873 $disconnect = 1; 2874 } 2875 2876 my $where = "1 = 1"; 2877 2878 if ($vc) { 2879 if ($vc eq 'customer') { 2880 $where = " role = 'P'"; 2881 } 2882 } 2883 2884 my $query = qq|SELECT id, description 2885 FROM department 2886 WHERE $where 2887 ORDER BY rn|; 2888 my $sth = $dbh->prepare($query); 2889 $sth->execute || $self->dberror($query); 2890 2891 @{ $self->{all_department} } = (); 2892 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) { 2893 push @{ $self->{all_department} }, $ref; 2894 } 2895 $sth->finish; 2896 2897 $self->all_years($myconfig, $dbh); 2898 2899 $self->reports($myconfig, $dbh, $self->{login}); 2900 2901 $dbh->disconnect if $disconnect; 2902 2903} 2904 2905 2906sub all_warehouses { 2907 my ($self, $myconfig, $dbh) = @_; 2908 2909 my $disconnect; 2910 if (! $dbh) { 2911 $dbh = $self->dbconnect($myconfig); 2912 $disconnect = 1; 2913 } 2914 2915 my %defaults = $self->get_defaults($dbh, \@{[qw(checkinventory forcewarehouse)]}); 2916 for (keys %defaults) { $self->{$_} = $defaults{$_} } 2917 2918 my $query = qq|SELECT id, description 2919 FROM warehouse 2920 ORDER BY rn|; 2921 my $sth = $dbh->prepare($query); 2922 $sth->execute || $self->dberror($query); 2923 2924 @{ $self->{all_warehouse} } = (); 2925 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) { 2926 push @{ $self->{all_warehouse} }, $ref; 2927 } 2928 $sth->finish; 2929 2930 $dbh->disconnect if $disconnect; 2931 2932} 2933 2934 2935sub all_roles { 2936 my ($self, $myconfig, $dbh) = @_; 2937 2938 my $disconnect; 2939 if (! $dbh) { 2940 $dbh = $self->dbconnect($myconfig); 2941 $disconnect = 1; 2942 } 2943 2944 my $query = qq|SELECT id, description 2945 FROM acsrole 2946 ORDER BY rn|; 2947 my $sth = $dbh->prepare($query); 2948 $sth->execute || $self->dberror($query); 2949 2950 @{ $self->{all_acsrole} } = (); 2951 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) { 2952 push @{ $self->{all_acsrole} }, $ref; 2953 } 2954 $sth->finish; 2955 2956 $dbh->disconnect if $disconnect; 2957 2958} 2959 2960 2961sub all_years { 2962 my ($self, $myconfig, $dbh) = @_; 2963 2964 my $disconnect; 2965 if (! $dbh) { 2966 $dbh = $self->dbconnect($myconfig); 2967 $disconnect = 1; 2968 } 2969 2970 # get years 2971 my $query = qq|SELECT MIN(transdate) FROM acc_trans|; 2972 my ($startdate) = $dbh->selectrow_array($query); 2973 my $query = qq|SELECT MAX(transdate) FROM acc_trans|; 2974 my ($enddate) = $dbh->selectrow_array($query); 2975 2976 if ($myconfig->{dateformat} =~ /^yy/) { 2977 ($startdate) = split /\W/, $startdate; 2978 ($enddate) = split /\W/, $enddate; 2979 } else { 2980 (@_) = split /\W/, $startdate; 2981 $startdate = $_[2]; 2982 (@_) = split /\W/, $enddate; 2983 $enddate = $_[2]; 2984 } 2985 2986 $self->{all_years} = (); 2987 $startdate = substr($startdate,0,4); 2988 $enddate = substr($enddate,0,4); 2989 2990 if ($startdate) { 2991 while ($enddate >= $startdate) { 2992 push @{ $self->{all_years} }, $enddate--; 2993 } 2994 } 2995 2996 %{ $self->{all_month} } = ( '01' => 'January', 2997 '02' => 'February', 2998 '03' => 'March', 2999 '04' => 'April', 3000 '05' => 'May ', 3001 '06' => 'June', 3002 '07' => 'July', 3003 '08' => 'August', 3004 '09' => 'September', 3005 '10' => 'October', 3006 '11' => 'November', 3007 '12' => 'December' ); 3008 3009 my %defaults = $self->get_defaults($dbh, \@{[qw(company method precision namesbynumber)]}); 3010 for (keys %defaults) { $self->{$_} = $defaults{$_} } 3011 $self->{method} ||= "accrual"; 3012 3013 $dbh->disconnect if $disconnect; 3014 3015} 3016 3017 3018sub all_countries { 3019 my ($self, $myconfig, $db, $dbh) = @_; 3020 3021 my $disconnect; 3022 3023 if (! $dbh) { 3024 $dbh = $self->dbconnect($myconfig); 3025 $disconnect = 1; 3026 } 3027 my $sth; 3028 my $query; 3029 3030 $query = qq|SELECT DISTINCT country 3031 FROM address a 3032 JOIN $db vc ON (vc.id = a.trans_id) 3033 WHERE country != '' 3034 ORDER BY 1|; 3035 $sth = $dbh->prepare($query); 3036 $sth->execute || $self->dberror($query); 3037 3038 $self->{all_countries} = (); 3039 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 3040 push @{ $self->{all_countries} }, $ref; 3041 } 3042 $sth->finish; 3043 3044 $dbh->disconnect if $disconnect; 3045 3046} 3047 3048 3049sub all_business { 3050 my ($self, $myconfig, $dbh) = @_; 3051 3052 my $disconnect; 3053 3054 if (! $dbh) { 3055 $dbh = $self->dbconnect($myconfig); 3056 $disconnect = 1; 3057 } 3058 my $sth; 3059 my $query; 3060 3061 $query = qq|SELECT * 3062 FROM business 3063 ORDER BY rn|; 3064 $sth = $dbh->prepare($query); 3065 $sth->execute || $self->dberror($query); 3066 3067 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 3068 push @{ $self->{all_business} }, $ref; 3069 } 3070 $sth->finish; 3071 3072 $dbh->disconnect if $disconnect; 3073 3074} 3075 3076 3077sub create_links { 3078 my ($self, $module, $myconfig, $vc) = @_; 3079 3080 # get last customers or vendors 3081 my ($query, $sth); 3082 3083 my $dbh = $self->dbconnect($myconfig); 3084 3085 my $key; 3086 my %xkeyref = (); 3087 3088 my @df = qw(closedto revtrans weightunit cdt precision roundchange cashovershort_accno_id referenceurl forcewarehouse); 3089 push @df, "lock_%"; 3090 my %defaults = $self->get_defaults($dbh, \@df); 3091 for (keys %defaults) { $self->{$_} = $defaults{$_} } 3092 3093 $self->get_peripherals($dbh); 3094 3095 3096 $self->{cashovershort_accno_id} *= 1; 3097 $query = qq|SELECT accno 3098 FROM chart 3099 WHERE id = $self->{cashovershort_accno_id} 3100 AND closed = '0'|; 3101 ($self->{cashovershort}) = $dbh->selectrow_array($query); 3102 3103 # now get the account numbers 3104 $query = qq|SELECT c.accno, c.description, c.link, 3105 l.description AS translation 3106 FROM chart c 3107 LEFT JOIN translation l ON (l.trans_id = c.id AND l.language_code = '$myconfig->{countrycode}') 3108 WHERE c.link LIKE '%$module%' 3109 AND c.closed = '0' 3110 ORDER BY c.accno|; 3111 $sth = $dbh->prepare($query); 3112 $sth->execute || $self->dberror($query); 3113 3114 $self->{accounts} = ""; 3115 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) { 3116 3117 foreach $key (split /:/, $ref->{link}) { 3118 if ($key =~ /$module/) { 3119 # cross reference for keys 3120 $xkeyref{$ref->{accno}} = $key; 3121 3122 $ref->{description} = $ref->{translation} if $ref->{translation}; 3123 3124 push @{ $self->{"${module}_links"}{$key} }, { accno => $ref->{accno}, 3125 description => $ref->{description} }; 3126 3127 $self->{accounts} .= "$ref->{accno} " if $key !~ /tax/; 3128 } 3129 } 3130 } 3131 $sth->finish; 3132 3133 my $arap = ($vc eq 'customer') ? 'ar' : 'ap'; 3134 3135 $self->remove_locks($myconfig, $dbh); 3136 3137 if ($self->{id} *= 1) { 3138 3139 $query = qq|SELECT a.invnumber, a.transdate, 3140 a.${vc}_id, a.datepaid, a.duedate, a.ordnumber, 3141 a.taxincluded, a.curr AS currency, a.notes, a.intnotes, 3142 a.terms, a.cashdiscount, a.discountterms, 3143 c.name AS $vc, c.${vc}number, a.department_id, 3144 d.description AS department, 3145 a.amount AS oldinvtotal, a.paid AS oldtotalpaid, 3146 a.employee_id, e.name AS employee, a.language_code, 3147 a.ponumber, a.approved, 3148 br.id AS batchid, br.description AS batchdescription, 3149 a.description, a.onhold, a.exchangerate, a.dcn, 3150 ch.accno AS bank_accno, ch.description AS bank_accno_description, 3151 t.description AS bank_accno_translation, 3152 pm.description AS paymentmethod, a.paymentmethod_id 3153 FROM $arap a 3154 JOIN $vc c ON (a.${vc}_id = c.id) 3155 LEFT JOIN employee e ON (e.id = a.employee_id) 3156 LEFT JOIN department d ON (d.id = a.department_id) 3157 LEFT JOIN vr ON (vr.trans_id = a.id) 3158 LEFT JOIN br ON (br.id = vr.br_id) 3159 LEFT JOIN chart ch ON (ch.id = a.bank_id) 3160 LEFT JOIN translation t ON (t.trans_id = ch.id AND t.language_code = '$myconfig->{countrycode}') 3161 LEFT JOIN paymentmethod pm ON (pm.id = a.paymentmethod_id) 3162 WHERE a.id = $self->{id}|; 3163 $sth = $dbh->prepare($query); 3164 $sth->execute || $self->dberror($query); 3165 3166 $ref = $sth->fetchrow_hashref(NAME_lc); 3167 3168 $ref->{exchangerate} ||= 1; 3169 3170 for (qw(oldinvtotal oldtotalpaid)) { $ref->{$_} = $self->round_amount($ref->{$_} / $ref->{exchangerate}, $self->{precision}) } 3171 for (keys %$ref) { $self->{$_} = $ref->{$_} } 3172 $sth->finish; 3173 3174 if ($self->{bank_accno}) { 3175 $self->{payment_accno} = ($self->{bank_accno_translation}) ? "$self->{bank_accno}--$self->{bank_accno_translation}" : "$self->{bank_accno}--$self->{bank_accno_description}"; 3176 } 3177 3178 if ($self->{paymentmethod_id}) { 3179 $self->{payment_method} = "$self->{paymentmethod}--$self->{paymentmethod_id}"; 3180 } 3181 3182 # get printed, emailed 3183 $query = qq|SELECT s.printed, s.emailed, s.spoolfile, s.formname 3184 FROM status s 3185 WHERE s.trans_id = $self->{id}|; 3186 $sth = $dbh->prepare($query); 3187 $sth->execute || $self->dberror($query); 3188 3189 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 3190 $self->{printed} .= "$ref->{formname} " if $ref->{printed}; 3191 $self->{emailed} .= "$ref->{formname} " if $ref->{emailed}; 3192 $self->{queued} .= "$ref->{formname} $ref->{spoolfile} " if $ref->{spoolfile}; 3193 } 3194 $sth->finish; 3195 for (qw(printed emailed queued)) { $self->{$_} =~ s/ +$//g } 3196 3197 # get recurring 3198 $self->get_recurring($dbh); 3199 3200 # get amounts from individual entries 3201 $query = qq|SELECT c.accno, c.description, c.closed, c.link, 3202 ac.source, ac.amount, 3203 ac.memo, ac.transdate, ac.cleared, ac.project_id, 3204 p.projectnumber, ac.id, y.exchangerate, 3205 l.description AS translation, 3206 pm.description AS paymentmethod, y.paymentmethod_id 3207 FROM acc_trans ac 3208 JOIN chart c ON (c.id = ac.chart_id) 3209 LEFT JOIN project p ON (p.id = ac.project_id) 3210 LEFT JOIN payment y ON (y.trans_id = ac.trans_id AND ac.id = y.id) 3211 LEFT JOIN paymentmethod pm ON (pm.id = y.paymentmethod_id) 3212 LEFT JOIN translation l ON (l.trans_id = c.id AND l.language_code = '$myconfig->{countrycode}') 3213 WHERE ac.trans_id = $self->{id} 3214 AND ac.fx_transaction = '0' 3215 ORDER BY ac.transdate|; 3216 $sth = $dbh->prepare($query); 3217 $sth->execute || $self->dberror($query); 3218 3219 my $resort; 3220 3221 # store amounts in {acc_trans}{$key} for multiple accounts 3222 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) { 3223 $ref->{description} = $ref->{translation} if $ref->{translation}; 3224 $ref->{exchangerate} ||= 1; 3225 if ($ref->{closed}) { 3226 # add account to {links}{key} 3227 for $key (split /:/, $ref->{link}) { 3228 if ($key =~ /$module/) { 3229 $resort = 1; 3230 # cross reference for keys 3231 $xkeyref{$ref->{accno}} = $key; 3232 3233 $ref->{description} = $ref->{translation} if $ref->{translation}; 3234 3235 push @{ $self->{"${module}_links"}{$key} }, 3236 { accno => $ref->{accno}, 3237 description => $ref->{description} }; 3238 $self->{accounts} .= "$ref->{accno} " if $key !~ /tax/; 3239 } 3240 } 3241 } 3242 push @{ $self->{acc_trans}{$xkeyref{$ref->{accno}}} }, $ref; 3243 } 3244 $sth->finish; 3245 3246 if ($resort) { 3247 for (keys %{ $self->{"${module}_links"} }) { 3248 @{ $self->{"${module}_links"}{$_} } = sort { $a->{accno} cmp $b->{accno} } @{ $self->{"${module}_links"}{$_} }; 3249 } 3250 } 3251 3252 $self->all_references($dbh); 3253 3254 $self->create_lock($myconfig, $dbh, $self->{id}, $arap); 3255 3256 } else { 3257 3258 # get date 3259 if (! $self->{transdate}) { 3260 $self->{transdate} = $self->current_date($myconfig); 3261 } 3262 if (! $self->{"$self->{vc}_id"}) { 3263 $self->lastname_used($myconfig, $dbh, $vc, $module); 3264 } 3265 3266 } 3267 3268 $self->all_vc($myconfig, $vc, $module, $dbh, $self->{transdate}); 3269 3270 $self->{currencies} = $self->get_currencies($myconfig, $dbh); 3271 3272 if ($self->{currency} ne substr($self->{currencies}, 0, 3)) { 3273 $self->{exchangerate} ||= $self->get_exchangerate($myconfig, $dbh, $self->{currency}, $self->{transdate}); 3274 } 3275 3276 # get paymentmethod 3277 $query = qq|SELECT * 3278 FROM paymentmethod 3279 ORDER BY rn|; 3280 $sth = $dbh->prepare($query); 3281 $sth->execute || $self->dberror($query); 3282 3283 @{ $self->{"all_paymentmethod"} } = (); 3284 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 3285 push @{ $self->{"all_paymentmethod"} }, $ref; 3286 } 3287 $sth->finish; 3288 3289 $dbh->disconnect; 3290 3291} 3292 3293 3294sub get_peripherals { 3295 my ($self, $dbh) = @_; 3296 3297 $self->{workstation} ||= $ENV{REMOTE_ADDR}; 3298 3299 my @df = map { "${_}_$self->{workstation}" } qw(workstation cashdrawer poledisplay poledisplayon); 3300 push @df, "printer_$self->{workstation}_%"; 3301 push @df, "printer_$self->{login}_%"; 3302 my %defaults = $self->get_defaults($dbh, \@df); 3303 3304 my $label; 3305 my $command; 3306 my %printer; 3307 3308 @{ $self->{all_printer} } = (); 3309 3310 if (%defaults) { 3311 for (sort keys %defaults) { 3312 if ($_ =~ /printer_/) { 3313 ($label, $command) = split /=/, $defaults{$_}; 3314 unless ($printer{$label}) { 3315 push @{ $self->{all_printer} }, { printer => $label, command => $command }; 3316 } 3317 $printer{$label} = 1; 3318 } else { 3319 $label = $_; 3320 $label =~ s/_.*//; 3321 $self->{$label} = $defaults{$_}; 3322 } 3323 } 3324 } else { 3325 @df = qw(printer_% cashdrawer poledisplay poledisplayon); 3326 %defaults = $self->get_defaults($dbh, \@df); 3327 3328 for (sort keys %defaults) { 3329 if ($_ =~ /printer_\d+$/) { 3330 ($label, $command) = split /=/, $defaults{$_}; 3331 unless ($printer{$label}) { 3332 push @{ $self->{all_printer} }, { printer => $label, command => $command }; 3333 } 3334 $printer{$label} = 1; 3335 } else { 3336 if ($_ !~ /printer_/) { 3337 $self->{$_} = $defaults{$_}; 3338 } 3339 } 3340 } 3341 } 3342 3343} 3344 3345 3346 3347sub create_lock { 3348 my ($self, $myconfig, $dbh, $id, $module, $add) = @_; 3349 3350 my $query; 3351 3352 my $disconnect; 3353 my $expires = time; 3354 3355 if (! $dbh) { 3356 $dbh = $self->dbconnect($myconfig); 3357 $disconnect = 1; 3358 } 3359 3360 # remove expired locks 3361 $query = qq|DELETE FROM semaphore 3362 WHERE expires < '$expires'|; 3363 $dbh->do($query) || $self->dberror($query); 3364 3365 $expires = time + $myconfig->{timeout}; 3366 3367 if ($id) { 3368 $query = qq|SELECT id, login FROM semaphore 3369 WHERE id = $id|; 3370 my ($readonly, $login) = $dbh->selectrow_array($query); 3371 3372 if ($readonly && ! $add) { 3373 $login =~ s/\@.*//; 3374 $query = qq|SELECT name FROM employee 3375 WHERE login = '$login'|; 3376 ($self->{haslock}) = $dbh->selectrow_array($query); 3377 $self->{haslock} ||= 'admin'; 3378 $self->{readonly} = 1; 3379 } else { 3380 $query = qq|INSERT INTO semaphore (id, login, module, expires) 3381 VALUES ($id, '$self->{login}', '$module', '$expires')|; 3382 $dbh->do($query) || $self->dberror($query); 3383 } 3384 } 3385 3386 $dbh->disconnect if $disconnect; 3387 3388} 3389 3390 3391sub remove_locks { 3392 my ($self, $myconfig, $dbh, $module) = @_; 3393 3394 my $disconnect; 3395 if (! $dbh) { 3396 $dbh = $self->dbconnect($myconfig); 3397 $disconnect = 1; 3398 } 3399 3400 my $query = qq|DELETE FROM semaphore 3401 WHERE login = '$self->{login}'|; 3402 $query .= qq| 3403 AND module = '$module'| if $module; 3404 $dbh->do($query); 3405 3406 $dbh->disconnect if $disconnect; 3407 3408} 3409 3410 3411sub lastname_used { 3412 my ($self, $myconfig, $dbh, $vc, $module) = @_; 3413 3414 my $arap = ($vc eq 'customer') ? "ar" : "ap"; 3415 my $where = "1 = 1"; 3416 my $sth; 3417 3418 if ($self->{type} =~ /_order/) { 3419 $arap = 'oe'; 3420 $where = "quotation = '0'"; 3421 } 3422 if ($self->{type} =~ /_quotation/) { 3423 $arap = 'oe'; 3424 $where = "quotation = '1'"; 3425 } 3426 3427 my $query = qq|SELECT id FROM $arap 3428 WHERE id IN (SELECT MAX(id) FROM $arap 3429 WHERE $where 3430 AND ${vc}_id > 0)|; 3431 my ($trans_id) = $dbh->selectrow_array($query); 3432 3433 $trans_id *= 1; 3434 3435 my $duedate; 3436 if ($myconfig->{dbdriver} eq 'DB2') { 3437 $duedate = ($self->{transdate}) ? qq|date '$self->{transdate}' + ct.terms DAYS| : qq|current_date + ct.terms DAYS|; 3438 } elsif ($myconfig->{dbdriver} eq 'Sybase') { 3439 $duedate = ($self->{transdate}) ? qq|dateadd($myconfig->{dateformat}, ct.terms DAYS, $self->{transdate})| : qq|dateadd($myconfig->{dateformat}, ct.terms DAYS, current_date)|; 3440 } else { 3441 $duedate = ($self->{transdate}) ? qq|date '$self->{transdate}' + ct.terms| : qq|current_date + ct.terms|; 3442 } 3443 3444 if ($trans_id) { 3445 $query = qq|SELECT ct.name AS $vc, ct.${vc}number, a.curr AS currency, 3446 a.${vc}_id, 3447 $duedate AS duedate, a.department_id, 3448 d.description AS department, ct.notes AS intnotes, 3449 ct.curr AS currency, ct.remittancevoucher 3450 FROM $arap a 3451 JOIN $vc ct ON (a.${vc}_id = ct.id) 3452 LEFT JOIN department d ON (a.department_id = d.id) 3453 WHERE a.id = $trans_id|; 3454 } else { 3455 $query = qq|SELECT ct.name AS $vc, ct.${vc}number, ct.id AS ${vc}_id, 3456 ct.notes AS intnotes, ct.curr AS currency, ct.remittancevoucher 3457 FROM $vc ct 3458 ORDER BY ct.name|; 3459 } 3460 $sth = $dbh->prepare($query); 3461 $sth->execute; 3462 3463 my $ref = $sth->fetchrow_hashref(NAME_lc); 3464 for (keys %$ref) { $self->{$_} = $ref->{$_} } 3465 $sth->finish; 3466 3467} 3468 3469 3470 3471sub current_date { 3472 my ($self, $myconfig, $date) = @_; 3473 3474 use Time::Local; 3475 3476 my $spc = $myconfig->{dateformat}; 3477 $spc =~ s/\w//g; 3478 $spc = substr($spc, 0, 1); 3479 my @t = localtime; 3480 my $dd; 3481 my $mm; 3482 my $yy; 3483 3484 if ($date) { 3485 if ($date =~ /\D/) { 3486 3487 if ($myconfig->{dateformat} =~ /^yy/) { 3488 ($yy, $mm, $dd) = split /\D/, $date; 3489 } 3490 if ($myconfig->{dateformat} =~ /^mm/) { 3491 ($mm, $dd, $yy) = split /\D/, $date; 3492 } 3493 if ($myconfig->{dateformat} =~ /^dd/) { 3494 ($dd, $mm, $yy) = split /\D/, $date; 3495 } 3496 3497 } else { 3498 # ISO 3499 $date =~ /(....)(..)(..)/; 3500 $yy = $1; 3501 $mm = $2; 3502 $dd = $3; 3503 } 3504 3505 $mm--; 3506 @t = (1,0,0,$dd,$mm,$yy); 3507 } 3508 3509 @t = localtime(timelocal(@t)); 3510 3511 $t[4]++; 3512 $mm = substr("0$t[4]",-2); 3513 $dd = substr("0$t[3]",-2); 3514 $yy = $t[5] + 1900; 3515 3516 if ($myconfig->{dateformat} =~ /\D/) { 3517 3518 if ($myconfig->{dateformat} =~ /^yy/) { 3519 $date = "$yy$spc$mm$spc$dd"; 3520 } 3521 if ($myconfig->{dateformat} =~ /^mm/) { 3522 $date = "$mm$spc$dd$spc$yy"; 3523 } 3524 if ($myconfig->{dateformat} =~ /^dd/) { 3525 $date = "$dd$spc$mm$spc$yy"; 3526 } 3527 3528 } else { 3529 $date = "$yy$mm$dd"; 3530 } 3531 3532 $date; 3533 3534} 3535 3536 3537sub like { 3538 my ($self, $str) = @_; 3539 3540 $str =~ s/;/\\;/g; 3541 3542 if ($str !~ /(%|_)/) { 3543 if ($str =~ /(^").*("$)/) { 3544 $str =~ s/(^"|"$)//g; 3545 } else { 3546 $str = "%$str%"; 3547 } 3548 } 3549 3550 $str =~ s/'/''/g; 3551 $str; 3552 3553} 3554 3555 3556sub redo_rows { 3557 my ($self, $flds, $new, $count, $numrows) = @_; 3558 3559 my @ndx = (); 3560 3561 for (1 .. $count) { push @ndx, { num => $new->[$_-1]->{runningnumber}, ndx => $_ } } 3562 3563 my $i = 0; 3564 # fill rows 3565 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) { 3566 $i++; 3567 $j = $item->{ndx} - 1; 3568 for (@{$flds}) { $self->{"${_}_$i"} = $new->[$j]->{$_} } 3569 } 3570 3571 # delete empty rows 3572 for $i ($count + 1 .. $numrows) { 3573 for (@{$flds}) { delete $self->{"${_}_$i"} } 3574 } 3575 3576} 3577 3578 3579sub get_partsgroup { 3580 my ($self, $myconfig, $p, $dbh) = @_; 3581 3582 my $disconnect; 3583 3584 if (! $dbh) { 3585 $dbh = $self->dbconnect($myconfig); 3586 $disconnect = 1; 3587 } 3588 3589 my $query = qq|SELECT DISTINCT pg.* 3590 FROM partsgroup pg 3591 JOIN parts p ON (p.partsgroup_id = pg.id)|; 3592 3593 my $where = qq|WHERE p.obsolete = '0'|; 3594 my $sortorder = "partsgroup"; 3595 3596 if ($p->{searchitems} eq 'part') { 3597 $where .= qq| 3598 AND (p.inventory_accno_id > 0 3599 AND p.income_accno_id > 0)|; 3600 } 3601 if ($p->{searchitems} eq 'partandassembly') { 3602 $where .= qq| 3603 AND (p.inventory_accno_id > 0 3604 AND p.income_accno_id > 0) 3605 OR p.assembly = '1'|; 3606 } 3607 if ($p->{searchitems} eq 'partassemblykit') { 3608 $where .= qq| 3609 AND (p.inventory_accno_id > 0 3610 AND p.income_accno_id > 0) 3611 OR p.assembly = '1' 3612 OR (p.inventory_accno_id IS NULL 3613 AND p.income_accno_id IS NULL 3614 AND p.expense_accno_id IS NULL)|; 3615 } 3616 3617 3618 if ($p->{searchitems} eq 'service') { 3619 $where .= qq| 3620 AND (p.inventory_accno_id IS NULL 3621 AND p.income_accno_id > 0) 3622 AND p.assembly = '0'|; 3623 } 3624 if ($p->{searchitems} eq 'assembly') { 3625 $where .= qq| 3626 AND p.assembly = '1'|; 3627 } 3628 if ($p->{searchitems} eq 'labor') { 3629 $where .= qq| 3630 AND p.inventory_accno_id > 0 AND p.income_accno_id IS NULL|; 3631 } 3632 if ($p->{searchitems} eq 'nolabor') { 3633 $where .= qq| 3634 AND p.income_accno_id > 0|; 3635 } 3636 if ($p->{searchitems} eq 'noservice') { 3637 $query = qq|$query 3638 $where 3639 AND NOT (p.inventory_accno_id IS NULL AND p.income_accno_id > 0) 3640 UNION 3641 $query 3642 $where 3643 AND (p.inventory_accno_id IS NULL 3644 AND p.income_accno_id IS NULL 3645 AND p.expense_accno_id IS NULL)|; 3646 $where = ""; 3647 } 3648 if ($p->{searchitems} eq 'kit') { 3649 $where .= qq| 3650 AND (p.inventory_accno_id IS NULL 3651 AND p.income_accno_id IS NULL 3652 AND p.expense_accno_id IS NULL)|; 3653 } 3654 3655 if ($p->{all}) { 3656 $query = qq|SELECT * 3657 FROM partsgroup|; 3658 $where = ""; 3659 } 3660 3661 if ($p->{language_code}) { 3662 $sortorder = "translation"; 3663 3664 $query = qq|SELECT DISTINCT pg.*, t.description AS translation 3665 FROM partsgroup pg 3666 JOIN parts p ON (p.partsgroup_id = pg.id) 3667 LEFT JOIN translation t ON (t.trans_id = pg.id AND t.language_code = '$p->{language_code}')|; 3668 } 3669 3670 $query .= qq| 3671 $where 3672 ORDER BY $sortorder|; 3673 3674 my $sth = $dbh->prepare($query); 3675 $sth->execute || $self->dberror($query); 3676 3677 if ($p->{language_code}) { 3678 $query = qq|SELECT pg.*, t.description AS translation 3679 FROM partsgroup pg 3680 LEFT JOIN translation t ON (t.trans_id = pg.id AND t.language_code = '$p->{language_code}') 3681 WHERE pg.partsgroup = ?|; 3682 } else { 3683 $query = qq|SELECT * 3684 FROM partsgroup 3685 WHERE partsgroup = ?|; 3686 } 3687 my $pth = $dbh->prepare($query) || $self->dberror($query); 3688 3689 $self->{all_partsgroup} = (); 3690 3691 my $partsgroup; 3692 my %partsgroup; 3693 my $ref; 3694 my $pref; 3695 my $i; 3696 my $pt; 3697 my @pt; 3698 my $id; 3699 my $str; 3700 3701 if ($self->{partsgroup}) { 3702 ($partsgroup, $id) = split /--/, $self->{partsgroup}; 3703 @pt = split /:/, $partsgroup; 3704 $id *= 1; 3705 3706 $query = qq|SELECT code FROM partsgroup 3707 WHERE id = $id|; 3708 ($self->{partsgroupcode}) = $dbh->selectrow_array($query); 3709 $self->{oldpartsgroupcode} = $self->{partsgroupcode}; 3710 } 3711 3712 if ($self->{partsgroupcode} ne $self->{oldpartsgroupcode}) { 3713 if ($self->{partsgroupcode}) { 3714 $query = qq|SELECT partsgroup, id 3715 FROM partsgroup 3716 WHERE code = '$self->{partsgroupcode}' 3717 ORDER BY partsgroup|; 3718 ($partsgroup, $id) = $dbh->selectrow_array($query); 3719 @pt = split /:/, $partsgroup; 3720 3721 $self->{partsgroup} = qq|$partsgroup--$id|; 3722 $self->{oldpartsgroup} = $self->{partsgroup}; 3723 $self->{oldpartsgroupcode} = $self->{partsgroupcode}; 3724 } 3725 } 3726 3727 my $level = $#pt + 1; 3728 3729 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 3730 3731 if ($p->{pos}) { 3732 if ($p->{parentgroup}) { 3733 if ($ref->{partsgroup} =~ /:/) { 3734 (@pt) = split /:/, $ref->{partsgroup}; 3735 $pth->execute($pt[0]); 3736 $pref = $pth->fetchrow_hashref(NAME_lc); 3737 $pth->finish; 3738 if ($pref && ! $partsgroup{$pref->{partsgroup}}) { 3739 push @{ $self->{all_partsgroup} }, $pref; 3740 $partsgroup{$pref->{partsgroup}} = 1; 3741 } 3742 } else { 3743 if (! $partsgroup{$ref->{partsgroup}}) { 3744 push @{ $self->{all_partsgroup} }, $ref; 3745 $partsgroup{$ref->{partsgroup}} = 1; 3746 } 3747 } 3748 } else { 3749 if ($ref->{partsgroup} =~ /^\Q$partsgroup\E:*?/) { 3750 (@pt) = split /:/, $ref->{partsgroup}; 3751 $str = ""; 3752 for (0 .. $level) { 3753 $str .= $pt[$_]; 3754 $pth->execute($str); 3755 $pref = $pth->fetchrow_hashref(NAME_lc); 3756 $pth->finish; 3757 if ($pref && ! $partsgroup{$pref->{partsgroup}}) { 3758 push @{ $self->{all_partsgroup} }, $pref; 3759 $partsgroup{$pref->{partsgroup}} = 1; 3760 } 3761 $str .= ":"; 3762 } 3763 } 3764 } 3765 } else { 3766 if ($partsgroup) { 3767 (@pt) = split /:/, $ref->{partsgroup}; 3768 if ($ref->{partsgroup} eq $pt[0]) { 3769 if (! $partsgroup{$ref->{partsgroup}}) { 3770 push @{ $self->{all_partsgroup} }, $ref; 3771 $partsgroup{$ref->{partsgroup}} = 1; 3772 next; 3773 } 3774 } 3775 3776 if ($ref->{partsgroup} =~ /^\Q$partsgroup\E:/) { 3777 $pt = $ref->{partsgroup}; 3778 $pt =~ s/\Q$partsgroup\E://; 3779 if ($pt !~ /:/) { 3780 if (! $partsgroup{$ref->{partsgroup}}) { 3781 push @{ $self->{all_partsgroup} }, $ref; 3782 $partsgroup{$ref->{partsgroup}} = 1; 3783 } 3784 } 3785 } 3786 3787 if ($ref->{partsgroup} =~ /^\Q$pt[0]\E:/) { 3788 $pt = "$pt[0]"; 3789 for $i (1 .. $#pt) { 3790 $pt .= ":$pt[$i]"; 3791 if ($ref->{partsgroup} eq $pt) { 3792 if (! $partsgroup{$ref->{partsgroup}}) { 3793 push @{ $self->{all_partsgroup} }, $ref; 3794 $partsgroup{$ref->{partsgroup}} = 1; 3795 } 3796 } 3797 } 3798 } 3799 } else { 3800 if ($p->{subgroup}) { 3801 push @{ $self->{all_partsgroup} }, $ref; 3802 $partsgroup{$ref->{partsgroup}} = 1; 3803 } else { 3804 if ($ref->{partsgroup} !~ /:/) { 3805 push @{ $self->{all_partsgroup} }, $ref; 3806 $partsgroup{$ref->{partsgroup}} = 1; 3807 } 3808 } 3809 } 3810 } 3811 3812 } 3813 $sth->finish; 3814 3815 my %defaults = $self->get_defaults($dbh, \@{['method']}); 3816 $self->{method} = ($defaults{method}) ? $defaults{method} : "accrual"; 3817 3818 $dbh->disconnect if $disconnect; 3819 3820} 3821 3822 3823sub update_status { 3824 my ($self, $myconfig) = @_; 3825 3826 # no id return 3827 $self->{id} *= 1; 3828 return unless $self->{id}; 3829 3830 my $dbh = $self->dbconnect_noauto($myconfig); 3831 3832 my %queued = split / +/, $self->{queued}; 3833 my $spoolfile = ($queued{$self->{formname}}) ? "'$queued{$self->{formname}}'" : 'NULL'; 3834 my $query = qq|DELETE FROM status 3835 WHERE formname = '$self->{formname}' 3836 AND trans_id = $self->{id}|; 3837 $dbh->do($query) || $self->dberror($query); 3838 3839 my $printed = ($self->{printed} =~ /$self->{formname}/) ? "1" : "0"; 3840 my $emailed = ($self->{emailed} =~ /$self->{formname}/) ? "1" : "0"; 3841 3842 $query = qq|INSERT INTO status (trans_id, printed, emailed, 3843 spoolfile, formname) VALUES ($self->{id}, '$printed', 3844 '$emailed', $spoolfile, 3845 '$self->{formname}')|; 3846 $dbh->do($query) || $self->dberror($query); 3847 3848 $dbh->commit; 3849 $dbh->disconnect; 3850 3851} 3852 3853 3854sub save_status { 3855 my ($self, $dbh) = @_; 3856 3857 my $formnames = $self->{printed}; 3858 my $emailforms = $self->{emailed}; 3859 3860 $self->{id} *= 1; 3861 my $query = qq|DELETE FROM status 3862 WHERE trans_id = $self->{id}|; 3863 $dbh->do($query) || $self->dberror($query); 3864 3865 my %queued; 3866 my $formname; 3867 3868 if ($self->{queued}) { 3869 %queued = split / +/, $self->{queued}; 3870 3871 foreach $formname (keys %queued) { 3872 3873 $printed = ($self->{printed} =~ /$formname/) ? "1" : "0"; 3874 $emailed = ($self->{emailed} =~ /$formname/) ? "1" : "0"; 3875 3876 if ($queued{$formname}) { 3877 $query = qq|INSERT INTO status (trans_id, printed, emailed, 3878 spoolfile, formname) 3879 VALUES ($self->{id}, '$printed', '$emailed', 3880 '$queued{$formname}', '$formname')|; 3881 $dbh->do($query) || $self->dberror($query); 3882 } 3883 3884 $formnames =~ s/$formname//; 3885 $emailforms =~ s/$formname//; 3886 3887 } 3888 } 3889 3890 # save printed, emailed info 3891 $formnames =~ s/^ +//g; 3892 $emailforms =~ s/^ +//g; 3893 3894 my %status = (); 3895 for (split / +/, $formnames) { $status{$_}{printed} = 1 } 3896 for (split / +/, $emailforms) { $status{$_}{emailed} = 1 } 3897 3898 foreach $formname (keys %status) { 3899 $printed = $status{$formname}{printed} * 1; 3900 $emailed = $status{$formname}{emailed} * 1; 3901 3902 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname) 3903 VALUES ($self->{id}, '$printed', '$emailed', '$formname')|; 3904 $dbh->do($query) || $self->dberror($query); 3905 } 3906 3907} 3908 3909 3910sub all_references { 3911 my ($self, $dbh, $formname) = @_; 3912 3913 my $login = $self->{login}; 3914 $login =~ s/\@.*//; 3915 # get reference documents 3916 if ($self->{id} *= 1) { 3917 my $query = qq|SELECT r.*, a.filename 3918 FROM reference r 3919 LEFT JOIN archive a ON (a.id = r.archive_id) 3920 WHERE r.trans_id = $self->{id}|; 3921 3922 if ($formname) { 3923 $query .= qq| 3924 AND r.formname = '$formname'|; 3925 } 3926 3927 my $sth = $dbh->prepare($query); 3928 $sth->execute || $self->dberror($query); 3929 3930 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 3931 if ($ref->{login}) { 3932 next if $ref->{login} ne $login; 3933 } 3934 $ref->{confidential} = ($login eq $ref->{login}); 3935 push @{ $self->{all_reference} }, $ref; 3936 } 3937 $sth->finish; 3938 } 3939 3940} 3941 3942 3943sub get_reference { 3944 my ($self, $myconfig) = @_; 3945 3946 my $dbh = $self->dbconnect($myconfig); 3947 3948 $self->{id} *= 1; 3949 my $query = qq|SELECT bt FROM archivedata 3950 WHERE archive_id = $self->{id} 3951 ORDER BY rn|; 3952 my $sth = $dbh->prepare($query) || $self->error($query); 3953 3954 $sth->execute; 3955 3956 my $data; 3957 my $str; 3958 3959 while ($str = $sth->fetchrow_array) { 3960 $data .= unpack 'u', $str; 3961 } 3962 $sth->finish; 3963 3964 $query = qq|SELECT r.description, a.filename 3965 FROM reference r 3966 JOIN archive a ON (r.archive_id = a.id) 3967 WHERE r.archive_id = $self->{id}|; 3968 ($self->{description}, $self->{filename}) = $dbh->selectrow_array($query); 3969 3970 if ($self->{filename} =~ /\./) { 3971 my @ext = split /\./, $self->{filename}; 3972 $self->{extension} = pop @ext; 3973 $self->{extension} = lc $self->{extension}; 3974 } 3975 3976 $query = qq|SELECT contenttype 3977 FROM mimetype 3978 WHERE lower(extension) = '$self->{extension}'|; 3979 ($self->{contenttype}) = $dbh->selectrow_array($query); 3980 3981 $dbh->disconnect; 3982 3983 $data; 3984 3985} 3986 3987 3988sub save_reference { 3989 my ($self, $dbh, $formname) = @_; 3990 3991 my $login = $self->{login}; 3992 $login =~ s/@.*//; 3993 my $archive_id; 3994 my %reference; 3995 my $i; 3996 my $data; 3997 my $str; 3998 my $query; 3999 my $sth; 4000 my $where = qq| AND (login = '$login' OR login = '' OR login IS NULL)|; 4001 $where .= qq| AND formname = '$formname'| if $formname; 4002 4003 if ($self->{id} *= 1) { 4004 $query = qq|SELECT archive_id 4005 FROM reference 4006 WHERE trans_id = $self->{id} 4007 $where 4008 |; 4009 $sth = $dbh->prepare($query) || $self->dberror($query); 4010 4011 $sth->execute || $self->dberror($query); 4012 4013 while (($archive_id) = $sth->fetchrow_array) { 4014 if ($archive_id) { 4015 $reference{$archive_id} = 1; 4016 } 4017 } 4018 $sth->finish; 4019 4020 $query = qq|DELETE FROM reference 4021 WHERE trans_id = $self->{id} 4022 AND (login = '$login' OR login = '' OR login IS NULL)|; 4023 $dbh->do($query) || $self->dberror($query); 4024 } 4025 4026 $query = qq|INSERT INTO reference (code, trans_id, description, archive_id, login, formname, folder) 4027 VALUES (?, ?, ?, ?, ?, ?, ?)|; 4028 $sth = $dbh->prepare($query) || $self->dberror($query); 4029 4030 $query = qq|DELETE FROM archive 4031 WHERE id = ?|; 4032 my $dth = $dbh->prepare($query) || $self->dberror($query); 4033 4034 $query = qq|INSERT INTO archive (filename) 4035 VALUES (?)|; 4036 my $aath = $dbh->prepare($query) || $self->dberror($query); 4037 4038 $query = qq|SELECT id FROM archive 4039 WHERE filename = ?|; 4040 my $sath = $dbh->prepare($query) || $self->dberror($query); 4041 4042 $query = qq|UPDATE archive SET filename = ? 4043 WHERE filename = ?|; 4044 my $uath = $dbh->prepare($query) || $self->dberror($query); 4045 4046 $query = qq|INSERT INTO archivedata (rn, archive_id, bt) 4047 VALUES (?, ?, ?)|; 4048 my $acth = $dbh->prepare($query) || $self->dberror($query); 4049 4050 for $i (1 .. $self->{reference_rows}) { 4051 $self->{"referencearchive_id_$i"} *= 1; 4052 delete $reference{$self->{"referencearchive_id_$i"}} if $self->{"referencedescription_$i"}; 4053 } 4054 4055 for (keys %reference) { 4056 $dth->execute($_); 4057 $dth->finish; 4058 } 4059 4060 my $uid = time; 4061 $uid .= $$; 4062 4063 4064 for $i (1 .. $self->{reference_rows}) { 4065 4066 if (! $self->{referenceurl}) { 4067 4068 if ($self->{"referencetmpfile_$i"}) { 4069 4070 $tmpfile = $self->{"referencetmpfile_$i"}; 4071 4072 if (-s "$self->{userspath}/$tmpfile") { 4073 4074 if (open(FH, "$self->{userspath}/$tmpfile")) { 4075 4076 binmode(FH); 4077 4078 $aath->execute($uid); 4079 $aath->finish; 4080 4081 $sath->execute($uid); 4082 ($self->{"referencearchive_id_$i"}) = $sath->fetchrow_array; 4083 $sath->finish; 4084 4085 $uath->execute($self->{"referencefilename_$i"}, $uid); 4086 $uath->finish; 4087 4088 my $j = 1; 4089 while (read FH, $data, 512) { 4090 $acth->execute($j++, $self->{"referencearchive_id_$i"}, pack 'u', $data); 4091 $acth->finish; 4092 } 4093 close(FH); 4094 } 4095 4096 } 4097 4098 unlink "$self->{userspath}/$tmpfile"; 4099 $self->{"referencedescription_$i"} ||= "***"; 4100 4101 } 4102 } 4103 4104 if ($self->{"referencedescription_$i"}) { 4105 delete $self->{"referencearchive_id_$i"} unless $self->{"referencearchive_id_$i"}; 4106 $self->{id} ||= $self->{trans_id}; 4107 delete $self->{id} unless $self->{id}; 4108 4109 $confidential = ($self->{"referenceconfidential_$i"}) ? $login : ""; 4110 4111 $sth->execute($self->{"referencecode_$i"}, $self->{id}, $self->{"referencedescription_$i"}, $self->{"referencearchive_id_$i"}, $confidential, $formname, $self->{"referencefolder_$i"}); 4112 $sth->finish; 4113 } 4114 } 4115 4116} 4117 4118 4119sub delete_references { 4120 my ($self, $dbh) = @_; 4121 4122 my $login = $self->{login}; 4123 $login =~ s/@.*//; 4124 4125 my $query = qq|SELECT archive_id 4126 FROM reference 4127 WHERE trans_id = $self->{id} 4128 AND (login = '$login' OR login = '' OR login IS NULL)|; 4129 my $sth = $dbh->prepare($query) || $self->dberror($query); 4130 4131 $query = qq|DELETE FROM archive 4132 WHERE id = ?|; 4133 my $dth = $dbh->prepare($query) || $self->dberror($query); 4134 4135 $sth->execute || $self->dberror($query); 4136 4137 while (my ($archive_id) = $sth->fetchrow_array) { 4138 if ($archive_id) { 4139 $dth->execute($archive_id); 4140 $dth->finish; 4141 } 4142 } 4143 $sth->finish; 4144 4145 $query = qq|DELETE FROM reference 4146 WHERE trans_id = $self->{id} 4147 AND (login = '$login' OR login = '' OR login IS NULL)|; 4148 $dbh->do($query) || $self->dberror($query); 4149 4150} 4151 4152 4153sub get_recurring { 4154 my ($self, $dbh) = @_; 4155 4156 $self->{id} *= 1; 4157 4158 my $query = qq|SELECT s.*, se.formname AS formnamee, se.format AS formate, 4159 se.message, 4160 sp.formname AS formnamep, sp.format AS formatp, sp.printer AS printerp 4161 FROM recurring s 4162 LEFT JOIN recurringemail se ON (s.id = se.id) 4163 LEFT JOIN recurringprint sp ON (s.id = sp.id) 4164 WHERE s.id = $self->{id}|; 4165 my $sth = $dbh->prepare($query); 4166 $sth->execute || $self->dberror($query); 4167 4168 for (qw(email print)) { $self->{"recurring$_"} = "" } 4169 4170 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) { 4171 for (keys %$ref) { $self->{"recurring$_"} = $ref->{$_} } 4172 $self->{recurringemail} .= "$ref->{formnamee}:$ref->{formate}:"; 4173 $self->{recurringprint} .= "$ref->{formnamep}:$ref->{formatp}:$ref->{printerp}:"; 4174 for (qw(formnamee formate formnamep formatp printerp)) { delete $self->{"recurring$_"} } 4175 } 4176 $sth->finish; 4177 chop $self->{recurringemail}; 4178 chop $self->{recurringprint}; 4179 4180 if ($self->{recurringstartdate}) { 4181 for (qw(reference description message)) { $self->{"recurring$_"} = $self->escape($self->{"recurring$_"},1) } 4182 for (qw(reference description startdate repeat unit howmany payment print email message)) { $self->{recurring} .= qq|$self->{"recurring$_"},| } 4183 chop $self->{recurring}; 4184 } 4185 4186} 4187 4188 4189sub save_recurring { 4190 my ($self, $dbh, $myconfig) = @_; 4191 4192 my $disconnect; 4193 if (! $dbh) { 4194 $dbh = $self->dbconnect_noauto($myconfig); 4195 $disconnect = 1; 4196 } 4197 4198 my $query; 4199 4200 for (qw(recurring recurringemail recurringprint)) { 4201 $query = qq|DELETE FROM $_ WHERE id = $self->{id}|; 4202 $dbh->do($query) || $self->dberror($query); 4203 } 4204 4205 if ($self->{recurring}) { 4206 my %s = (); 4207 ($s{reference}, $s{description}, $s{startdate}, $s{repeat}, $s{unit}, $s{howmany}, $s{payment}, $s{print}, $s{email}, $s{message}) = split /,/, $self->{recurring}; 4208 4209 for (qw(reference description message)) { $s{$_} = $self->unescape($s{$_}) } 4210 for (qw(repeat howmany payment)) { $s{$_} *= 1 } 4211 4212 # calculate enddate 4213 my $advance = $s{repeat} * ($s{howmany} - 1); 4214 my %interval = ( 'Pg' => "(date '$s{startdate}' + interval '$advance $s{unit}')", 4215 'Sybase' => "dateadd($myconfig->{dateformat}, $advance $s{unit}, $s{startdate})", 4216 'DB2' => qq|(date ('$s{startdate}') + "$advance $s{unit}")|, 4217 ); 4218 $interval{Oracle} = $interval{PgPP} = $interval{Pg}; 4219 $query = qq|SELECT $interval{$myconfig->{dbdriver}} 4220 FROM defaults 4221 WHERE fldname = 'version'|; 4222 my ($enddate) = $dbh->selectrow_array($query); 4223 4224 # calculate nextdate 4225 if ($myconfig->{dbdriver} eq 'Sybase') { 4226 $query = qq|SELECT datediff($myconfig->{dateformat}, $s{startdate}, current_date) AS a, 4227 datediff($myconfig->{dateformat}, current_date, $enddate) AS b 4228 FROM defaults 4229 WHERE fldname = 'version'|; 4230 } else { 4231 $query = qq|SELECT current_date - date '$s{startdate}' AS a, 4232 date '$enddate' - current_date AS b 4233 FROM defaults 4234 WHERE fldname = 'version'|; 4235 } 4236 my ($x, $y) = $dbh->selectrow_array($query); 4237 4238 if ($x + $y) { 4239 $advance = int(($x / ($x + $y)) * $s{howmany} + 1) * $s{repeat}; 4240 } else { 4241 $advance = 0; 4242 } 4243 4244 my $nextdate = $enddate; 4245 if ($advance > 0) { 4246 if ($advance < ($s{repeat} * $s{howmany})) { 4247 %interval = ( 'Pg' => "(date '$s{startdate}' + interval '$advance $s{unit}')", 4248 'Sybase' => "dateadd($myconfig->{dateformat}, $advance $s{unit}, $s{startdate})", 4249 'DB2' => qq|(date ('$s{startdate}') + "$advance $s{unit}")|, 4250 ); 4251 $interval{Oracle} = $interval{PgPP} = $interval{Pg}; 4252 $query = qq|SELECT $interval{$myconfig->{dbdriver}} 4253 FROM defaults 4254 WHERE fldname = 'version'|; 4255 ($nextdate) = $dbh->selectrow_array($query); 4256 } 4257 } else { 4258 $nextdate = $s{startdate}; 4259 } 4260 4261 if ($self->{recurringnextdate}) { 4262 $nextdate = $self->{recurringnextdate}; 4263 4264 $query = qq|SELECT '$enddate' - date '$nextdate' 4265 FROM defaults 4266 WHERE fldname = 'version'|; 4267 if ($myconfig->{dbdriver} eq 'Sybase') { 4268 $query = qq|SELECT datediff($myconfig->{dateformat}, $enddate, $nextdate) 4269 FROM defaults 4270 WHERE fldname = 'version'|; 4271 } 4272 4273 if ($dbh->selectrow_array($query) < 0) { 4274 undef $nextdate; 4275 } 4276 } 4277 4278 $self->{recurringpayment} *= 1; 4279 $query = qq|INSERT INTO recurring (id, reference, description, 4280 startdate, enddate, nextdate, 4281 repeat, unit, howmany, payment) 4282 VALUES ($self->{id}, |.$dbh->quote($s{reference}).qq|, 4283 |.$dbh->quote($s{description}).qq|, 4284 '$s{startdate}', '$enddate', |. 4285 $self->dbquote($nextdate, SQL_DATE). 4286 qq|, $s{repeat}, '$s{unit}', $s{howmany}, '$s{payment}')|; 4287 $dbh->do($query) || $self->dberror($query); 4288 4289 my @p; 4290 my $p; 4291 my $i; 4292 my $sth; 4293 4294 if ($s{email}) { 4295 # formname:format 4296 @p = split /:/, $s{email}; 4297 4298 $query = qq|INSERT INTO recurringemail (id, formname, format, message) 4299 VALUES ($self->{id}, ?, ?, ?)|; 4300 $sth = $dbh->prepare($query) || $self->dberror($query); 4301 4302 for ($i = 0; $i <= $#p; $i += 2) { 4303 $sth->execute($p[$i], $p[$i+1], $s{message}); 4304 } 4305 $sth->finish; 4306 } 4307 4308 if ($s{print}) { 4309 # formname:format:printer 4310 @p = split /:/, $s{print}; 4311 4312 $query = qq|INSERT INTO recurringprint (id, formname, format, printer) 4313 VALUES ($self->{id}, ?, ?, ?)|; 4314 $sth = $dbh->prepare($query) || $self->dberror($query); 4315 4316 for ($i = 0; $i <= $#p; $i += 3) { 4317 $p = ($p[$i+2]) ? $p[$i+2] : ""; 4318 $sth->execute($p[$i], $p[$i+1], $p); 4319 } 4320 $sth->finish; 4321 } 4322 4323 } 4324 4325 if ($disconnect) { 4326 $dbh->commit; 4327 $dbh->disconnect; 4328 } 4329 4330} 4331 4332 4333sub save_intnotes { 4334 my ($self, $myconfig, $vc) = @_; 4335 4336 # no id return 4337 $self->{id} *= 1; 4338 return unless $self->{id}; 4339 4340 my $dbh = $self->dbconnect($myconfig); 4341 4342 my $query = qq|UPDATE $vc SET 4343 intnotes = |.$dbh->quote($self->{intnotes}).qq| 4344 WHERE id = $self->{id}|; 4345 $dbh->do($query) || $self->dberror($query); 4346 4347 $dbh->disconnect; 4348 4349} 4350 4351 4352sub update_defaults { 4353 my ($self, $myconfig, $fld, $dbh, $ini) = @_; 4354 4355 my $disconnect; 4356 4357 if (! $dbh) { 4358 $dbh = $self->dbconnect_noauto($myconfig); 4359 $disconnect = 1; 4360 } 4361 4362 my $query = qq|SELECT fldname FROM defaults 4363 WHERE fldname = '$fld'|; 4364 $ini =~ s/;.*//g; 4365 4366 if (! $dbh->selectrow_array($query)) { 4367 if ($ini) { 4368 $query = qq|INSERT INTO defaults (fldname, fldvalue) 4369 VALUES ('$fld', '$ini')|; 4370 } else { 4371 $query = qq|INSERT INTO defaults (fldname) 4372 VALUES ('$fld')|; 4373 } 4374 $dbh->do($query) || $self->dberror($query); 4375 $dbh->commit; 4376 } else { 4377 if ($ini) { 4378 $query = qq|UPDATE defaults SET 4379 fldvalue = '$ini' 4380 WHERE fldname = '$fld'|; 4381 $dbh->do($query) || $self->dberror($query); 4382 $dbh->commit; 4383 } 4384 } 4385 4386 $query = qq|SELECT fldvalue FROM defaults 4387 WHERE fldname = '$fld' FOR UPDATE|; 4388 ($_) = $dbh->selectrow_array($query); 4389 4390 $_ = "0" unless $_; 4391 4392 # check for and replace 4393 # <%DATE%>, <%YYMMDD%>, <%YEAR%>, <%MONTH%>, <%DAY%> or variations of 4394 # <%NAME 1 1 3%>, <%BUSINESS%>, <%BUSINESS 10%>, <%CURR...%> 4395 # <%DESCRIPTION 1 1 3%>, <%ITEM 1 1 3%>, <%PARTSGROUP 1 1 3%> only for parts 4396 # <%PHONE%> for customer and vendors 4397 # <%YY%>, <%MM%>, <%DD%>, <%FDM%>, <%LDM%> 4398 4399 my $num = $_; 4400 $num =~ s/.*?<%.*?%>//g; 4401 ($num) = $num =~ /(\d+)/; 4402 4403 if (defined $num) { 4404 my $incnum; 4405 # if we have leading zeros check how long it is 4406 if ($num =~ /^0/) { 4407 my $l = length $num; 4408 $incnum = $num + 1; 4409 $l -= length $incnum; 4410 4411 # pad it out with zeros 4412 my $padzero = "0" x $l; 4413 $incnum = ("0" x $l) . $incnum; 4414 } else { 4415 $incnum = $num + 1; 4416 } 4417 4418 s/$num/$incnum/; 4419 } 4420 4421 my $dbvar = $_; 4422 my $var = $_; 4423 my $str; 4424 my $param; 4425 4426 if (/<%/) { 4427 while (/<%/) { 4428 s/<%.*?%>//; 4429 last unless $&; 4430 $param = $&; 4431 $str = ""; 4432 4433 if ($param =~ /<%date%>/i) { 4434 $str = ($self->split_date($myconfig->{dateformat}, $self->{transdate}))[0]; 4435 $var =~ s/$param/$str/i; 4436 } 4437 4438 if ($param =~ /<%(name|business|description|item|partsgroup|phone|custom)/i) { 4439 my $fld = lc $1; 4440 if ($fld =~ /name/) { 4441 if ($self->{type}) { 4442 $fld = $self->{vc}; 4443 } 4444 } 4445 4446 my $p = $param; 4447 $p =~ s/(<|>|%)//g; 4448 my @p = split / /, $p; 4449 my @n = split / /, uc $self->{$fld}; 4450 if ($#p > 0) { 4451 for (my $i = 1; $i <= $#p; $i++) { 4452 $str .= substr($n[$i-1], 0, $p[$i]); 4453 } 4454 } else { 4455 ($str) = split /--/, $self->{$fld}; 4456 } 4457 $var =~ s/$param/$str/; 4458 4459 $var =~ s/\W//g if $fld eq 'phone'; 4460 } 4461 4462 if ($param =~ /<%(yy|mm|dd)/i) { 4463 my $p = $param; 4464 my $mdy = $1; 4465 $p =~ s/(<|>|%)//g; 4466 4467 if (! $ml) { 4468 my $spc = $p; 4469 $spc =~ s/\w//g; 4470 $spc = substr($spc, 0, 1); 4471 my %d = ( yy => 1, mm => 2, dd => 3 ); 4472 my @p = (); 4473 4474 my @date = $self->split_date($myconfig->{dateformat}, $self->{transdate}); 4475 if ($p =~ /yyyy/i) { 4476 $date[1] += 2000; 4477 } 4478 4479 for (sort keys %d) { 4480 push @p, $date[$d{$_}] if ($p =~ /$_/i); 4481 } 4482 $str = join $spc, @p; 4483 } 4484 4485 $var =~ s/$param/$str/i; 4486 } 4487 4488 if ($param =~ /<%(fdm|ldm)%>/i) { 4489 $str = $self->dayofmonth($myconfig->{dateformat}, $self->{transdate}, $1); 4490 $var =~ s/$param/$str/i; 4491 } 4492 4493 if ($param =~ /<%curr/i) { 4494 $var =~ s/$param/$self->{currency}/i; 4495 } 4496 4497 } 4498 } 4499 4500 $query = qq|UPDATE defaults 4501 SET fldvalue = '$dbvar' 4502 WHERE fldname = '$fld'|; 4503 $dbh->do($query) || $self->dberror($query); 4504 4505 if ($disconnect) { 4506 $dbh->commit; 4507 $dbh->disconnect; 4508 } 4509 4510 $var; 4511 4512} 4513 4514 4515sub reports { 4516 my ($self, $myconfig, $dbh, $login) = @_; 4517 4518 my $disconnect; 4519 my $ref; 4520 4521 if (! $dbh) { 4522 $dbh = $self->dbconnect($myconfig); 4523 $disconnect = 1; 4524 } 4525 4526 4527 my $query = qq|SELECT r.* FROM report r 4528 WHERE r.reportcode = |.$dbh->quote($self->{reportcode}); 4529 4530 # no login if admin|roles = 0|1 4531 $login =~ s/\@.*//; 4532 $login = "" if $login eq 'admin'; 4533 4534 my $qu = qq|SELECT count(*) 4535 FROM acsrole|; 4536 if ($dbh->selectrow_array($qu) <= 1) { 4537 $login = ""; 4538 } 4539 4540 if ($login) { 4541 $query .= qq| 4542 AND (r.login = '$login' OR r.login = '')|; 4543 } 4544 4545 $query .= qq| 4546 ORDER BY r.reportdescription|; 4547 my $sth = $dbh->prepare($query); 4548 $sth->execute || $self->dberror($query); 4549 4550 @{ $self->{all_report} } = (); 4551 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 4552 push @{ $self->{all_report} }, $ref; 4553 } 4554 $sth->finish; 4555 4556 $query = qq|SELECT rv.* 4557 FROM reportvars rv 4558 JOIN report r ON (r.reportid = rv.reportid) 4559 WHERE r.reportcode = |.$dbh->quote($self->{reportcode}); 4560 4561 if ($login) { 4562 $query .= qq| 4563 AND (r.login = '$login' OR r.login = '')|; 4564 } 4565 $query .= qq| 4566 ORDER BY r.reportid|; 4567 $sth = $dbh->prepare($query); 4568 $sth->execute || $self->dberror($query); 4569 4570 while ($ref = $sth->fetchrow_hashref(NAME_lc)) { 4571 $self->{all_reportvars}{$ref->{reportid}}{$ref->{reportvariable}} = $ref->{reportvalue}; 4572 } 4573 $sth->finish; 4574 4575 $query = qq|SELECT to_char(current_date, '$self->{dateformat}') 4576 FROM defaults WHERE fldname = 'version'|; 4577 ($self->{dateprepared}) = $dbh->selectrow_array($query); 4578 4579 $dbh->disconnect if $disconnect; 4580 4581} 4582 4583 4584sub retrieve_report { 4585 my ($self, $myconfig, $dbh) = @_; 4586 4587 $self->{reportid} *= 1; 4588 return unless $self->{reportid}; 4589 4590 my $disconnect; 4591 4592 if (! $dbh) { 4593 $dbh = $self->dbconnect($myconfig); 4594 $disconnect = 1; 4595 } 4596 4597 my $query = qq|SELECT * FROM reportvars 4598 WHERE reportid = $self->{reportid}|; 4599 my $sth = $dbh->prepare($query); 4600 $sth->execute || $self->dberror($query); 4601 4602 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) { 4603 $self->{$ref->{reportvariable}} = $ref->{reportvalue}; 4604 } 4605 $sth->finish; 4606 4607 $dbh->disconnect if $disconnect; 4608 4609} 4610 4611 4612sub report_level { 4613 my ($self, $myconfig, $dbh) = @_; 4614 4615 my $disconnect; 4616 4617 if (! $dbh) { 4618 $dbh = $self->dbconnect($myconfig); 4619 $disconnect = 1; 4620 } 4621 4622 $self->{reportid} *= 1; 4623 4624 my $query = qq|SELECT login 4625 FROM report 4626 WHERE reportid = $self->{reportid}|; 4627 4628 my $login = $self->{login}; 4629 $login =~ s/@.*//; 4630 4631 if ($login eq 'admin') { 4632 4633 $self->{admin} = 1; 4634 $self->{savereport} = 1; 4635 4636 } else { 4637 4638 # reportlogin lt login 4639 $query = qq|SELECT a.rn 4640 FROM employee e 4641 JOIN acsrole a ON (a.id = e.acsrole_id) 4642 WHERE e.login = ?|; 4643 my $sth = $dbh->prepare($query) || $self->dberror($query); 4644 4645 $sth->execute($login); 4646 my ($l2) = $sth->fetchrow_array; 4647 $sth->finish; 4648 4649 $sth->execute($self->{reportlogin}); 4650 my ($l1) = $sth->fetchrow_array; 4651 $sth->finish; 4652 4653 if ($l1 > $l2 || $l2 == 0 || $l2 == 1) { 4654 $self->{admin} = 1; 4655 $self->{savereport} = 1; 4656 } 4657 $self->{savereport} = 1 if ! $self->{reportid}; 4658 $self->{savereport} = 1 if $self->{reportlogin} eq $login; 4659 4660 } 4661 4662 $dbh->disconnect if $disconnect; 4663 4664} 4665 4666 4667sub save_report { 4668 my ($self, $myconfig) = @_; 4669 4670 my $dbh = $self->dbconnect_noauto($myconfig); 4671 4672 my $query; 4673 my $sth; 4674 4675 if ($self->{reportid} *= 1) { 4676 $query = qq|DELETE FROM reportvars 4677 WHERE reportid = '$self->{reportid}'|; 4678 $dbh->do($query) || $self->dberror($query); 4679 4680 $query = qq|DELETE FROM report 4681 WHERE reportid = '$self->{reportid}'|; 4682 $dbh->do($query) || $self->dberror($query); 4683 } 4684 4685 if ($self->{reportdescription}) { 4686 if ($self->{reportid}) { 4687 $query = qq|INSERT INTO report (reportid) 4688 VALUES ($self->{reportid})|; 4689 $dbh->do($query) || $self->dberror($query); 4690 } else { 4691 my $uid = localtime; 4692 $uid .= $$; 4693 4694 $query = qq|INSERT INTO report (reportdescription) 4695 VALUES ('$uid')|; 4696 $dbh->do($query) || $self->dberror($query); 4697 4698 $query = qq|SELECT reportid FROM report 4699 WHERE reportdescription = '$uid'|; 4700 ($self->{reportid}) = $dbh->selectrow_array($query); 4701 } 4702 4703 $query = qq|UPDATE report SET 4704 reportcode = '$self->{reportcode}', 4705 reportdescription = |.$dbh->quote($self->{reportdescription}).qq|, 4706 login = '$self->{reportlogin}' 4707 WHERE reportid = $self->{reportid}|; 4708 $dbh->do($query) || $self->dberror($query); 4709 4710 $query = qq|INSERT INTO reportvars (reportid, reportvariable, reportvalue) VALUES ($self->{reportid}, ?, ?)|; 4711 $sth = $dbh->prepare($query); 4712 4713 my %newform; 4714 for (keys %$self) { 4715 if ($self->{$_} !~ /(HASH|ARRAY)/) { 4716 $newform{$_} = $self->{$_} unless $_ =~ /ndx_\d+$/; 4717 } 4718 } 4719 for (qw(path login stylesheet dbversion report reportid reportcode reportdescription action script nextsub allbox charset timeout sessioncookie callback title version rowcount flds defaultcurrency selectlanguage savereport admin)) { delete $newform{$_} } 4720 4721 for (keys %newform) { 4722 $sth->execute("report_$_", $newform{$_}) || $self->dberror($query); 4723 $sth->finish; 4724 } 4725 } 4726 4727 $dbh->commit; 4728 $dbh->disconnect; 4729 4730} 4731 4732 4733 4734 4735sub sort_column_index { 4736 my ($self) = @_; 4737 4738 my @c = split /,/, $self->{column_index}; 4739 my $i = 1; 4740 my %c; 4741 my $v; 4742 my $j; 4743 my $k; 4744 my %d; 4745 my $ndx; 4746 my $lastndx; 4747 my %temp; 4748 4749 my (@m) = split /,/, $self->{movecolumn}; 4750 4751 for (@c) { 4752 ($v, $j) = split /=/, $_; 4753 $c{$v} = $i; 4754 $d{$v} = $j; 4755 $ndx = $i if $v eq $m[0]; 4756 $lastndx = $i; 4757 $i++; 4758 } 4759 4760 if ($m[1] eq 'right') { 4761 $c{$m[0]} += 1.5; 4762 $i = $ndx + 1; 4763 4764 if (exists $self->{"a_1"}) { 4765 if ($i == $lastndx + 1) { 4766 for (qw(a w f l)) { 4767 $temp{$_} = $self->{"${_}_$lastndx"}; 4768 $temp{"t_$_"} = $self->{"t_${_}_$lastndx"}; 4769 $temp{"h_$_"} = $self->{"h_${_}_$lastndx"}; 4770 } 4771 for $i (1 .. $lastndx - 1) { 4772 for (qw(a w f l)) { 4773 $k = $lastndx - $i + 1; 4774 $j = $lastndx - $i; 4775 $self->{"${_}_$k"} = $self->{"${_}_$j"}; 4776 $self->{"t_${_}_$k"} = $self->{"t_${_}_$j"}; 4777 $self->{"h_${_}_$k"} = $self->{"h_${_}_$j"}; 4778 } 4779 } 4780 for (qw(a w f l)) { 4781 $self->{"${_}_1"} = $temp{$_}; 4782 $self->{"t_${_}_1"} = $temp{"t_$_"}; 4783 $self->{"h_${_}_1"} = $temp{"h_$_"}; 4784 } 4785 4786 $i = 1; 4787 $ndx = 1; 4788 $c{$m[0]} = 0; 4789 } 4790 } 4791 } else { 4792 $c{$m[0]} -= 1.5; 4793 $i = $ndx - 1; 4794 4795 if (exists $self->{"a_1"}) { 4796 if ($i == 0) { 4797 for (qw(a w f l)) { 4798 $temp{$_} = $self->{"${_}_1"}; 4799 $temp{"t_$_"} = $self->{"t_${_}_1"}; 4800 $temp{"h_$_"} = $self->{"h_${_}_1"}; 4801 } 4802 for $i (1 .. $lastndx - 1) { 4803 for (qw(a w f l)) { 4804 $j = $i + 1; 4805 $self->{"${_}_$i"} = $self->{"${_}_$j"}; 4806 $self->{"t_${_}_$i"} = $self->{"t_${_}_$j"}; 4807 $self->{"h_${_}_$i"} = $self->{"h_${_}_$j"}; 4808 } 4809 } 4810 for (qw(a w f l)) { 4811 $self->{"${_}_$lastndx"} = $temp{$_}; 4812 $self->{"t_${_}_$lastndx"} = $temp{"t_$_"}; 4813 $self->{"h_${_}_$lastndx"} = $temp{"h_$_"}; 4814 } 4815 4816 $i = 1; 4817 $ndx = 1; 4818 $c{$m[0]} = $lastndx + 1; 4819 } 4820 } 4821 } 4822 4823 for (qw(a w f l)) { 4824 $temp{$_} = $self->{"${_}_$ndx"}; 4825 $temp{"t_$_"} = $self->{"t_${_}_$ndx"}; 4826 $temp{"h_$_"} = $self->{"h_${_}_$ndx"}; 4827 $self->{"${_}_$ndx"} = $self->{"${_}_$i"}; 4828 $self->{"t_${_}_$ndx"} = $self->{"t_${_}_$i"}; 4829 $self->{"h_${_}_$ndx"} = $self->{"h_${_}_$i"}; 4830 $self->{"${_}_$i"} = $temp{$_}; 4831 $self->{"t_${_}_$i"} = $temp{"t_$_"}; 4832 $self->{"h_${_}_$i"} = $temp{"h_$_"}; 4833 } 4834 4835 $self->{column_index} = ""; 4836 @c = (); 4837 for (sort { $c{$a} <=> $c{$b} } keys %c) { 4838 push @c, $_; 4839 $self->{column_index} .= "$_=$d{$_},"; 4840 } 4841 chop $self->{column_index}; 4842 4843 @c; 4844 4845} 4846 4847 4848sub split_date { 4849 my ($self, $dateformat, $date) = @_; 4850 4851 my @t = localtime; 4852 my $mm; 4853 my $dd; 4854 my $yy; 4855 my $yyyy; 4856 my $rv; 4857 4858 if (! $date) { 4859 $dd = $t[3]; 4860 $mm = ++$t[4]; 4861 $yy = substr($t[5],-2); 4862 $yyyy = substr($t[5]+1900,-4); 4863 $mm = substr("0$mm", -2); 4864 $dd = substr("0$dd", -2); 4865 } 4866 4867 if ($dateformat =~ /^yy/) { 4868 if ($date) { 4869 if ($date =~ /\D/) { 4870 ($yy, $mm, $dd) = split /\D/, $date; 4871 $mm *= 1; 4872 $dd *= 1; 4873 $mm = substr("0$mm", -2); 4874 $dd = substr("0$dd", -2); 4875 $yyyy = substr($yy, -4); 4876 $yy = substr($yy, -2); 4877 4878 $rv = "$yyyy$mm$dd"; 4879 } else { 4880 $rv = $date; 4881 $date =~ /(....)(..)(..)/; 4882 $yy = $1; 4883 $mm = $2; 4884 $dd = $3; 4885 } 4886 $mm = substr("0$mm", -2); 4887 $dd = substr("0$dd", -2); 4888 $yy = substr($yy, -2); 4889 } else { 4890 $rv = "$yyyy$mm$dd"; 4891 } 4892 } 4893 4894 if ($dateformat =~ /^mm/) { 4895 if ($date) { 4896 if ($date =~ /\D/) { 4897 ($mm, $dd, $yy) = split /\D/, $date; 4898 $mm *= 1; 4899 $dd *= 1; 4900 $mm = substr("0$mm", -2); 4901 $dd = substr("0$dd", -2); 4902 $yyyy = substr($yy, -4); 4903 $yy = substr($yy, -2); 4904 $rv = "$mm$dd$yyyy"; 4905 } else { 4906 $rv = $date; 4907 } 4908 } else { 4909 $rv = "$mm$dd$yyyy"; 4910 } 4911 } 4912 4913 if ($dateformat =~ /^dd/) { 4914 if ($date) { 4915 if ($date =~ /\D/) { 4916 ($dd, $mm, $yy) = split /\D/, $date; 4917 $mm *= 1; 4918 $dd *= 1; 4919 $mm = substr("0$mm", -2); 4920 $dd = substr("0$dd", -2); 4921 $yyyy = substr($yy, -4); 4922 $yy = substr($yy, -2); 4923 $rv = "$dd$mm$yyyy"; 4924 } else { 4925 $rv = $date; 4926 } 4927 } else { 4928 $rv = "$dd$mm$yyyy"; 4929 } 4930 } 4931 4932 ($rv, $yy, $mm, $dd); 4933 4934} 4935 4936 4937sub dayofmonth { 4938 my ($self, $dateformat, $date, $fdm) = @_; 4939 4940 my $rv = $date; 4941 my @date = $self->split_date($dateformat, $date); 4942 my $bd = 0; 4943 4944 my $spc = $date; 4945 $spc =~ s/\w//g; 4946 $spc = substr($spc, 0, 1); 4947 4948 use Time::Local; 4949 4950 $date[2]-- if $date[2]; 4951 4952 if (lc $fdm ne 'fdm') { 4953 $bd = 1; 4954 $date[2]++; 4955 if ($date[2] > 11) { 4956 $date[2] = 0; 4957 $date[1]++; 4958 } 4959 } 4960 4961 my @t = localtime(timelocal(0,0,0,1,$date[2],$date[1]) - $bd); 4962 4963 $t[4]++; 4964 $t[4] = substr("0$t[4]",-2); 4965 $t[3] = substr("0$t[3]",-2); 4966 $t[5] += 1900; 4967 4968 if ($dateformat =~ /^yy/) { 4969 $rv = "$t[5]$spc$t[4]$spc$t[3]"; 4970 } 4971 4972 if ($dateformat =~ /^mm/) { 4973 $rv = "$t[4]$spc$t[3]$spc$t[5]"; 4974 } 4975 4976 if ($dateformat =~ /^dd/) { 4977 $rv = "$t[3]$spc$t[4]$spc$t[5]"; 4978 } 4979 4980 $rv; 4981 4982} 4983 4984 4985sub from_to { 4986 my ($self, $yy, $mm, $interval) = @_; 4987 4988 use Time::Local; 4989 4990 my @t; 4991 my $dd = 1; 4992 my $fromdate = "$yy${mm}01"; 4993 my $bd = 1; 4994 4995 if (defined $interval) { 4996 if ($interval == 12) { 4997 $yy++; 4998 } else { 4999 if (($mm += $interval) > 12) { 5000 $mm -= 12; 5001 $yy++; 5002 } 5003 if ($interval == 0) { 5004 @t = localtime; 5005 $dd = $t[3]; 5006 $mm = $t[4] + 1; 5007 $yy = $t[5] + 1900; 5008 $bd = 0; 5009 } 5010 } 5011 } else { 5012 if (++$mm > 12) { 5013 $mm -= 12; 5014 $yy++; 5015 } 5016 } 5017 5018 $mm--; 5019 @t = localtime(timelocal(0,0,0,$dd,$mm,$yy) - $bd); 5020 5021 $t[4]++; 5022 $t[4] = substr("0$t[4]",-2); 5023 $t[3] = substr("0$t[3]",-2); 5024 $t[5] += 1900; 5025 5026 ($fromdate, "$t[5]$t[4]$t[3]"); 5027 5028} 5029 5030 5031sub fdld { 5032 my ($self, $myconfig, $locale) = @_; 5033 5034 $self->{fdm} = $self->dayofmonth($myconfig->{dateformat}, $self->{transdate}, 'fdm'); 5035 $self->{ldm} = $self->dayofmonth($myconfig->{dateformat}, $self->{transdate}); 5036 5037 my $transdate = $self->datetonum($myconfig, $self->{transdate}); 5038 5039 $self->{yy} = substr($transdate, 2, 2); 5040 ($self->{yyyy}, $self->{mm}, $self->{dd}) = $transdate =~ /(....)(..)(..)/; 5041 5042 my $m1; 5043 my $m2; 5044 my $y1; 5045 my $y2; 5046 my $d1; 5047 my $d2; 5048 my $d3; 5049 my $d4; 5050 5051 for (1 .. 11) { 5052 $m1 = $self->{mm} + $_; 5053 $y1 = $self->{yyyy}; 5054 if ($m1 > 12) { 5055 $m1 -= 12; 5056 $y1++; 5057 } 5058 $m1 = substr("0$m1", -2); 5059 5060 $m2 = $self->{mm} - $_; 5061 $y2 = $self->{yyyy}; 5062 if ($m2 < 1) { 5063 $m2 += 12; 5064 $y2--; 5065 } 5066 $m2 = substr("0$m2", -2); 5067 5068 $d1 = $self->format_date($myconfig->{dateformat}, "$y1${m1}01"); 5069 $d2 = $self->format_date($myconfig->{dateformat}, $self->dayofmonth("yyyymmdd", "$y1${m1}01")); 5070 $d3 = $self->format_date($myconfig->{dateformat}, "$y2${m2}01"); 5071 $d4 = $self->format_date($myconfig->{dateformat}, $self->dayofmonth("yyyymmdd", "$y2${m2}01")); 5072 5073 5074 if (exists $self->{longformat}) { 5075 $self->{"fdm+$_"} = $locale->date($myconfig, $d1, $self->{longformat}); 5076 $self->{"ldm+$_"} = $locale->date($myconfig, $d2, $self->{longformat}); 5077 $self->{"fdm-$_"} = $locale->date($myconfig, $d3, $self->{longformat}); 5078 $self->{"ldm-$_"} = $locale->date($myconfig, $d4, $self->{longformat}); 5079 } else { 5080 $self->{"fdm+$_"} = $d1; 5081 $self->{"ldm+$_"} = $d2; 5082 $self->{"fdm-$_"} = $d3; 5083 $self->{"ldm-$_"} = $d4; 5084 } 5085 } 5086 5087 $d1 = $self->format_date($myconfig->{dateformat}, "$self->{yyyy}$self->{mm}01"); 5088 $d2 = $self->format_date($myconfig->{dateformat}, $self->dayofmonth("yyyymmdd", "$self->{yyyy}$self->{mm}01")); 5089 5090 if (exists $self->{longformat}) { 5091 $self->{fdm} = $locale->date($myconfig, $self->{fdm}, $self->{longformat}); 5092 $self->{ldm} = $locale->date($myconfig, $self->{ldm}, $self->{longformat}); 5093 $self->{fdy} = $locale->date($myconfig, $d1, $self->{longformat}); 5094 $self->{ldy} = $locale->date($myconfig, $d2, $self->{longformat}); 5095 } else { 5096 $self->{fdy} = $d1; 5097 $self->{ldy} = $d2; 5098 } 5099 5100 for (1 .. 3) { 5101 $y1 = $self->{yyyy} + $_; 5102 $y2 = $self->{yyyy} - $_; 5103 5104 $d1 = $self->format_date($myconfig->{dateformat}, "$y1$self->{mm}01"); 5105 $d2 = $self->format_date($myconfig->{dateformat}, $self->dayofmonth("yyyymmdd", "$y1$self->{mm}01")); 5106 $d3 = $self->format_date($myconfig->{dateformat}, "$y2$self->{mm}01"); 5107 $d4 = $self->format_date($myconfig->{dateformat}, $self->dayofmonth("yyyymmdd", "$y2$self->{mm}01")); 5108 5109 if (exists $self->{longformat}) { 5110 $self->{"fdy+$_"} = $locale->date($myconfig, $d1, $self->{longformat}); 5111 $self->{"ldy+$_"} = $locale->date($myconfig, $d2, $self->{longformat}); 5112 $self->{"fdy-$_"} = $locale->date($myconfig, $d3, $self->{longformat}); 5113 $self->{"ldy-$_"} = $locale->date($myconfig, $d4, $self->{longformat}); 5114 } else { 5115 $self->{"fdy+$_"} = $d1; 5116 $self->{"ldy+$_"} = $d2; 5117 $self->{"fdy-$_"} = $d3; 5118 $self->{"ldy-$_"} = $d4; 5119 } 5120 5121 } 5122 5123} 5124 5125 5126sub audittrail { 5127 my ($self, $dbh, $myconfig, $audittrail) = @_; 5128 5129# table, $reference, $formname, $action, $id, $transdate) = @_; 5130 5131 my $query; 5132 my $rv; 5133 my $disconnect; 5134 5135 if (! $dbh) { 5136 $dbh = $self->dbconnect($myconfig); 5137 $disconnect = 1; 5138 } 5139 5140 # if we have an id add audittrail, otherwise get a new timestamp 5141 5142 if ($audittrail->{id} *= 1) { 5143 5144 $audittrail->{id} = 'NULL' if $audittrail->{id} == 1; 5145 5146 my %defaults = $self->get_defaults($dbh, \@{['audittrail']}); 5147 5148 if ($defaults{audittrail}) { 5149 my $employee_id; 5150 (undef, $employee_id) = $self->get_employee($dbh); 5151 5152 if ($self->{audittrail} && ! $myconfig) { 5153 chop $self->{audittrail}; 5154 5155 my @at = split /\|/, $self->{audittrail}; 5156 my %newtrail = (); 5157 my $key; 5158 my $i; 5159 my @flds = qw(tablename reference formname action transdate); 5160 5161 # put into hash and remove dups 5162 while (@at) { 5163 $key = "$at[2]$at[3]"; 5164 $i = 0; 5165 $newtrail{$key} = { map { $_ => $at[$i++] } @flds }; 5166 splice @at, 0, 5; 5167 } 5168 5169 $query = qq|INSERT INTO audittrail (trans_id, tablename, reference, 5170 formname, action, employee_id, transdate) 5171 VALUES ($audittrail->{id}, ?, ?, 5172 ?, ?, $employee_id, ?)|; 5173 my $sth = $dbh->prepare($query) || $self->dberror($query); 5174 5175 foreach $key (sort { $newtrail{$a}{transdate} cmp $newtrail{$b}{transdate} } keys %newtrail) { 5176 $i = 1; 5177 for (@flds) { $sth->bind_param($i++, $newtrail{$key}{$_}) } 5178 5179 $sth->execute || $self->dberror; 5180 $sth->finish; 5181 } 5182 } 5183 5184 5185 if ($audittrail->{transdate}) { 5186 $query = qq|INSERT INTO audittrail (trans_id, tablename, reference, 5187 formname, action, employee_id, transdate) VALUES ( 5188 $audittrail->{id}, '$audittrail->{tablename}', | 5189 .$dbh->quote($audittrail->{reference}).qq|', 5190 '$audittrail->{formname}', '$audittrail->{action}', 5191 $employee_id, '$audittrail->{transdate}')|; 5192 } else { 5193 $query = qq|INSERT INTO audittrail (trans_id, tablename, reference, 5194 formname, action, employee_id) VALUES ($audittrail->{id}, 5195 '$audittrail->{tablename}', | 5196 .$dbh->quote($audittrail->{reference}).qq|, 5197 '$audittrail->{formname}', '$audittrail->{action}', 5198 $employee_id)|; 5199 } 5200 $dbh->do($query); 5201 } 5202 } else { 5203 5204 $query = qq|SELECT current_timestamp FROM defaults 5205 WHERE fldname = 'version'|; 5206 my ($timestamp) = $dbh->selectrow_array($query); 5207 5208 $rv = "$audittrail->{tablename}|$audittrail->{reference}|$audittrail->{formname}|$audittrail->{action}|$timestamp|"; 5209 } 5210 5211 $dbh->disconnect if $disconnect; 5212 5213 $rv; 5214 5215} 5216 5217 5218package Locale; 5219 5220 5221sub new { 5222 my ($type, $country, $NLS_file) = @_; 5223 my $self = {}; 5224 5225 %self = (); 5226 if ($country && -d "locale/$country") { 5227 $self->{countrycode} = $country; 5228 eval { require "locale/$country/$NLS_file"; }; 5229 } 5230 5231 $self->{NLS_file} = $NLS_file; 5232 5233 push @{ $self->{LONG_MONTH} }, ("January", "February", "March", "April", "May ", "June", "July", "August", "September", "October", "November", "December"); 5234 push @{ $self->{SHORT_MONTH} }, (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)); 5235 5236 bless $self, $type; 5237 5238} 5239 5240 5241sub text { 5242 my ($self, $text) = @_; 5243 5244 return (exists $self{texts}{$text}) ? $self{texts}{$text} : $text; 5245 5246} 5247 5248 5249sub findsub { 5250 my ($self, $text) = @_; 5251 5252 return (exists $self{subs}{$text}) ? $self{subs}{$text} : $text; 5253 5254} 5255 5256 5257sub date { 5258 my ($self, $myconfig, $date, $longformat) = @_; 5259 5260 my $longdate = ""; 5261 my $longmonth = ($longformat) ? 'LONG_MONTH' : 'SHORT_MONTH'; 5262 5263 5264 if ($date) { 5265 # get separator 5266 $spc = $myconfig->{dateformat}; 5267 $spc =~ s/\w//g; 5268 $spc = substr($spc, 0, 1); 5269 5270 if ($date =~ /\D/) { 5271 if ($myconfig->{dateformat} =~ /^yy/) { 5272 ($yy, $mm, $dd) = split /\D/, $date; 5273 } 5274 if ($myconfig->{dateformat} =~ /^mm/) { 5275 ($mm, $dd, $yy) = split /\D/, $date; 5276 } 5277 if ($myconfig->{dateformat} =~ /^dd/) { 5278 ($dd, $mm, $yy) = split /\D/, $date; 5279 } 5280 } else { 5281 if (length $date > 6) { 5282 ($yy, $mm, $dd) = ($date =~ /(....)(..)(..)/); 5283 } else { 5284 ($yy, $mm, $dd) = ($date =~ /(..)(..)(..)/); 5285 } 5286 } 5287 5288 $dd *= 1; 5289 $mm--; 5290 $yy += 2000 if length $yy == 2; 5291 5292 if ($myconfig->{dateformat} =~ /^dd/) { 5293 $mm++; 5294 $dd = substr("0$dd", -2); 5295 $mm = substr("0$mm", -2); 5296 $longdate = "$dd$spc$mm$spc$yy"; 5297 5298 if ($longformat ne "") { 5299 $longdate = "$dd"; 5300 $longdate .= ($spc eq '.') ? ". " : " "; 5301 $longdate .= &text($self, $self->{$longmonth}[--$mm])." $yy"; 5302 } 5303 } elsif ($myconfig->{dateformat} =~ /^yy/) { 5304 $mm++; 5305 $dd = substr("0$dd", -2); 5306 $mm = substr("0$mm", -2); 5307 $longdate = "$yy$spc$mm$spc$dd"; 5308 5309 if ($longformat ne "") { 5310 $longdate = &text($self, $self->{$longmonth}[--$mm])." $dd $yy"; 5311 } 5312 } else { 5313 $mm++; 5314 $dd = substr("0$dd", -2); 5315 $mm = substr("0$mm", -2); 5316 $longdate = "$mm$spc$dd$spc$yy"; 5317 5318 if ($longformat ne "") { 5319 $longdate = &text($self, $self->{$longmonth}[--$mm])." $dd $yy"; 5320 } 5321 } 5322 5323 } 5324 5325 $longdate; 5326 5327} 5328 5329 53301; 5331 5332