1 #=================================================================
2 # SQL-Ledger Accounting
5 # Author: Dieter Simader
6 # Email: dsimader@sql-ledger.org
7 # Web: http://www.sql-ledger.org
9 # Contributors: Thomas Bayen <bayen@gmx.de>
10 # Antti Kaihola <akaihola@siba.fi>
12 # Jim Rawlings <jim@your-dba.com> (DB2)
14 # This program is free software; you can redistribute it and/or modify
15 # it under the terms of the GNU General Public License as published by
16 # the Free Software Foundation; either version 2 of the License, or
17 # (at your option) any later version.
19 # This program is distributed in the hope that it will be useful,
20 # but WITHOUT ANY WARRANTY; without even the implied warranty of
21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 # GNU General Public License for more details.
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
26 #======================================================================
30 #======================================================================
40 read(STDIN, $_, $ENV{CONTENT_LENGTH});
42 if ($ENV{QUERY_STRING}) {
43 $_ = $ENV{QUERY_STRING};
50 foreach $item (split(/&/)) {
51 ($key, $value) = split(/=/, $item);
52 $self->{$key} = &unescape("",$value);
55 $self->{menubar} = 1 if $self->{path} =~ /lynx/i;
57 if (substr($self->{action}, 0, 1) !~ /( |\.)/) {
58 $self->{action} = lc $self->{action};
59 $self->{action} =~ s/(( |-|,|#|\/)|\.$)/_/g;
62 $self->{version} = "2.4.4";
63 $self->{dbversion} = "2.4.4";
75 map { print "$_ = $self->{$_}\n" } (sort keys %$self);
81 my ($self, $str, $beenthere) = @_;
83 # for Apache 2 we escape strings twice
84 if (($ENV{SERVER_SIGNATURE} =~ /Apache\/2\.(\d+)\.(\d+)/) && !$beenthere) {
85 $str = $self->escape($str, 1) if $2 < 44;
88 $str =~ s/([^a-zA-Z0-9_.-])/sprintf("%%%02x", ord($1))/ge;
95 my ($self, $str) = @_;
100 $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
108 my ($self, $str) = @_;
110 if ($str && ! ref($str)) {
111 $str =~ s/"/"/g;
122 map { print qq|<input type=hidden name=$_ value="|.$self->quote($self->{$_}).qq|">\n| } sort keys %$self;
128 my ($self, $msg) = @_;
130 if ($ENV{HTTP_USER_AGENT}) {
135 if (!$self->{header}) {
139 print qq|<body><h2 class=error>Error!</h2>
147 if ($self->{error_function}) {
148 &{ $self->{error_function} }($msg);
158 my ($self, $msg) = @_;
160 if ($ENV{HTTP_USER_AGENT}) {
165 if (!$self->{header}) {
172 print "<br><b>$msg</b>";
176 if ($self->{info_function}) {
177 &{ $self->{info_function} }($msg);
189 my ($self, $str, $cols, $maxrows) = @_;
193 map { $rows += int (((length) - 2)/$cols) + 1 } split /\r/, $str;
195 $maxrows = $rows unless defined $maxrows;
197 return ($rows > $maxrows) ? $maxrows : $rows;
203 my ($self, $msg) = @_;
205 $self->error("$msg\n".$DBI::errstr);
211 my ($self, $name, $msg) = @_;
213 if ($self->{$name} =~ /^\s*$/) {
220 my ($self, $init) = @_;
222 return if $self->{header};
224 my ($stylesheet, $favicon, $charset);
226 if ($ENV{HTTP_USER_AGENT}) {
228 if ($self->{stylesheet} && (-f "css/$self->{stylesheet}")) {
229 $stylesheet = qq|<LINK REL="stylesheet" HREF="css/$self->{stylesheet}" TYPE="text/css" TITLE="SQL-Ledger stylesheet">
233 if ($self->{favicon} && (-f "$self->{favicon}")) {
234 $favicon = qq|<LINK REL="shortcut icon" HREF="$self->{favicon}" TYPE="image/x-icon">
238 if ($self->{charset}) {
239 $charset = qq|<META HTTP-EQUIV="Content-Type" CONTENT="text/plain; charset=$self->{charset}">
243 $self->{titlebar} = ($self->{title}) ? "$self->{title} - $self->{titlebar}" : $self->{titlebar};
245 $self->set_cookie($init);
247 print qq|Content-Type: text/html
250 <title>$self->{titlebar}</title>
266 my ($self, $init) = @_;
268 $self->{timeout} = ($self->{timeout} > 0) ? $self->{timeout} : 3600;
270 if ($self->{endsession}) {
273 $_ = time + $self->{timeout};
276 if ($ENV{HTTP_USER_AGENT}) {
278 my @d = split / +/, scalar gmtime($_);
279 my $today = "$d[0], $d[2]-$d[1]-$d[4] $d[3] GMT";
282 $self->{sessionid} = time;
284 print qq|Set-Cookie: SQL-Ledger-$self->{login}=$self->{sessionid}; expires=$today; path=/;\n| if $self->{login};
291 my ($self, $msg) = @_;
293 if ($self->{callback}) {
295 ($script, $argv) = split(/\?/, $self->{callback});
296 exec ("perl", "$script", $argv);
308 my ($self, @columns) = @_;
312 @columns = grep !/^$self->{sort}$/, @columns;
313 splice @columns, 0, 0, $self->{sort};
323 my ($self, $columns, $ordinal) = @_;
326 if ($self->{direction}) {
327 if ($self->{sort} eq $self->{oldsort}) {
328 if ($self->{direction} eq 'ASC') {
329 $self->{direction} = "DESC";
331 $self->{direction} = "ASC";
335 $self->{direction} = "ASC";
337 $self->{oldsort} = $self->{sort};
339 my $sortorder = join ',', $self->sort_columns(@{$columns});
342 map { $sortorder =~ s/$_/$ordinal->{$_}/ } keys %$ordinal;
344 my @a = split /,/, $sortorder;
345 $a[0] = "$a[0] $self->{direction}";
346 $sortorder = join ',', @a;
354 my ($self, $myconfig, $amount, $places, $dash) = @_;
356 if ($places =~ /\d/) {
357 $amount = $self->round_amount($amount, $places);
360 # is the amount negative
361 my $negative = ($amount < 0);
364 if ($myconfig->{numberformat} && ($myconfig->{numberformat} ne '1000.00')) {
365 my ($whole, $dec) = split /\./, "$amount";
367 $amount = join '', reverse split //, $whole;
369 if ($myconfig->{numberformat} eq '1,000.00') {
370 $amount =~ s/\d{3,}?/$&,/g;
372 $amount = join '', reverse split //, $amount;
373 $amount .= "\.$dec" if ($dec ne "");
376 if ($myconfig->{numberformat} eq "1'000.00") {
377 $amount =~ s/\d{3,}?/$&'/g;
379 $amount = join '', reverse split //, $amount;
380 $amount .= "\.$dec" if ($dec ne "");
383 if ($myconfig->{numberformat} eq '1.000,00') {
384 $amount =~ s/\d{3,}?/$&./g;
386 $amount = join '', reverse split //, $amount;
387 $amount .= ",$dec" if ($dec ne "");
390 if ($myconfig->{numberformat} eq '1000,00') {
392 $amount .= ",$dec" if ($dec ne "");
396 $amount = ($negative) ? "($amount)" : "$amount";
397 } elsif ($dash =~ /DRCR/) {
398 $amount = ($negative) ? "$amount DR" : "$amount CR";
400 $amount = ($negative) ? "-$amount" : "$amount";
404 if ($dash eq "0" && $places) {
405 if ($myconfig->{numberformat} eq '1.000,00') {
406 $amount = "0".","."0" x $places;
408 $amount = "0"."."."0" x $places;
411 $amount = ($dash ne "") ? "$dash" : "";
421 my ($self, $myconfig, $amount) = @_;
423 if (($myconfig->{numberformat} eq '1.000,00') ||
424 ($myconfig->{numberformat} eq '1000,00')) {
429 if ($myconfig->{numberformat} eq "1'000.00") {
435 return ($amount * 1);
441 my ($self, $amount, $places) = @_;
443 # $places = 3 if $places == 2;
445 if (($places * 1) >= 0) {
447 sprintf("%.${places}f", $amount + (1 / (10 ** ($places + 3))) * (($amount > 0) ? 1 : -1));
450 sprintf("%.f", $amount / (10 ** $places) + (($amount > 0) ? 0.1 : -0.1)) * (10 ** $places);
457 my ($self, $myconfig, $userspath) = @_;
459 my ($chars_per_line, $lines_on_first_page, $lines_on_second_page) = (0, 0, 0);
460 my ($current_page, $current_line) = (1, 1);
467 if ($self->{language_code}) {
468 if (-f "$self->{templates}/$self->{language_code}/$self->{IN}") {
469 open(IN, "$self->{templates}/$self->{language_code}/$self->{IN}") or $self->error("$self->{IN} : $!");
471 open(IN, "$self->{templates}/$self->{IN}") or $self->error("$self->{IN} : $!");
474 open(IN, "$self->{templates}/$self->{IN}") or $self->error("$self->{IN} : $!");
480 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
482 # OUT is used for the media, screen, printer, email
483 # for postscript we store a copy in a temporary file
485 my $tmpfile = $self->{IN};
486 $tmpfile =~ s/\./\.$self->{fileid}./ if $self->{fileid};
487 $self->{tmpfile} = "$userspath/${fileid}.${tmpfile}";
489 if ($self->{format} =~ /(postscript|pdf)/ || $self->{media} eq 'email') {
491 $self->{OUT} = ">$self->{tmpfile}";
495 open(OUT, "$self->{OUT}") or $self->error("$self->{OUT} : $!");
497 open(OUT, ">-") or $self->error("STDOUT : $!");
503 # first we generate a tmpfile
504 # read file and replace <%variable%>
511 # detect pagebreak block and its parameters
512 if (/\s*<%pagebreak ([0-9]+) ([0-9]+) ([0-9]+)%>/) {
513 $chars_per_line = $1;
514 $lines_on_first_page = $2;
515 $lines_on_second_page = $3;
518 last if (/\s*<%end pagebreak%>/);
524 if (/\s*<%foreach /) {
526 # this one we need for the count
528 $var =~ s/\s*<%foreach (.+?)%>/$1/;
530 last if (/\s*<%end /);
536 # display contents of $self->{number}[] array
537 for $i (0 .. $#{ $self->{$var} }) {
539 # Try to detect whether a manual page break is necessary
540 # but only if there was a <%pagebreak ...%> block before
542 if ($chars_per_line) {
543 my $lines = int(length($self->{"description"}[$i]) / $chars_per_line + 0.95);
546 if ($current_page == 1) {
547 $lpp = $lines_on_first_page;
549 $lpp = $lines_on_second_page;
552 # Yes we need a manual page break
553 if (($current_line + $lines) > $lpp) {
556 # replace the special variables <%sumcarriedforward%>
559 my $psum = $self->format_amount($myconfig, $sum, 2);
560 $pb =~ s/<%sumcarriedforward%>/$psum/g;
561 $pb =~ s/<%lastpage%>/$current_page/g;
563 # only "normal" variables are supported here
564 # (no <%if, no <%foreach, no <%include)
566 $pb =~ s/<%(.+?)%>/$self->{$1}/g;
568 # page break block is ready to rock
573 $current_line += $lines;
575 $sum += $self->parse_amount($myconfig, $self->{"linetotal"}[$i]);
577 # don't parse par, we need it for each line
578 print OUT $self->format_line($par, $i);
584 # if not comes before if!
585 if (/\s*<%if not /) {
586 # check if it is not set and display
588 s/\s*<%if not (.+?)%>/$1/;
590 unless ($self->{$_}) {
592 last if (/\s*<%end /);
602 last if (/\s*<%end /);
609 # check if it is set and display
611 s/\s*<%if (.+?)%>/$1/;
615 last if (/\s*<%end /);
625 last if (/\s*<%end /);
631 # check for <%include filename%>
632 if (/\s*<%include /) {
636 $var =~ s/\s*<%include (.+?)%>/$1/;
639 $var =~ s/(\/|\.\.)//g;
641 # prevent the infinite loop!
642 next if ($self->{"$var"});
644 unless (open(INC, "$self->{templates}/$var")) {
647 $self->error("$self->{templates}/$var : $err");
657 print OUT $self->format_line($_);
664 # Convert the tex file to postscript
665 if ($self->{format} =~ /(postscript|pdf)/) {
668 $self->{cwd} = cwd();
669 $self->{tmpdir} = "$self->{cwd}/$userspath";
671 unless (chdir("$userspath")) {
674 $self->error("chdir : $err");
677 $self->{tmpfile} =~ s/$userspath\///g;
679 if ($self->{format} eq 'postscript') {
680 system("latex --interaction=nonstopmode $self->{tmpfile} > $self->{tmpfile}.err");
681 $self->error($self->cleanup) if ($?);
683 $self->{tmpfile} =~ s/tex$/dvi/;
685 system("dvips $self->{tmpfile} -o -q");
686 $self->error($self->cleanup."dvips : $!") if ($?);
687 $self->{tmpfile} =~ s/dvi$/ps/;
689 if ($self->{format} eq 'pdf') {
690 system("pdflatex --interaction=nonstopmode $self->{tmpfile} > $self->{tmpfile}.err");
691 $self->error($self->cleanup) if ($?);
692 $self->{tmpfile} =~ s/tex$/pdf/;
698 if ($self->{format} =~ /(postscript|pdf)/ || $self->{media} eq 'email') {
700 if ($self->{media} eq 'email') {
704 my $mail = new Mailer;
706 map { $mail->{$_} = $self->{$_} } qw(cc bcc subject message version format charset);
707 $mail->{to} = qq|$self->{email}|;
708 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
709 $mail->{fileid} = "$fileid.";
711 # if we send html or plain text inline
712 if (($self->{format} =~ /(html|txt)/) && ($self->{sendmode} eq 'inline')) {
714 $br = "<br>" if $self->{format} eq 'html';
716 $mail->{contenttype} = "text/$self->{format}";
718 $mail->{message} =~ s/\r\n/$br\n/g;
719 $myconfig->{signature} =~ s/\\n/$br\n/g;
720 $mail->{message} .= "$br\n-- $br\n$myconfig->{signature}\n$br" if $myconfig->{signature};
722 unless (open(IN, $self->{tmpfile})) {
725 $self->error("$self->{tmpfile} : $err");
729 $mail->{message} .= $_;
736 @{ $mail->{attachments} } = ($self->{tmpfile});
738 $myconfig->{signature} =~ s/\\n/\r\n/g;
739 $mail->{message} .= "\r\n-- \r\n$myconfig->{signature}" if $myconfig->{signature};
743 if ($err = $mail->send($out)) {
751 unless (open(IN, $self->{tmpfile})) {
754 $self->error("$self->{tmpfile} : $err");
759 $self->{copies} = 1 if $self->{media} =~ /(screen|email|queue)/;
761 chdir("$self->{cwd}");
763 for my $i (1 .. $self->{copies}) {
765 unless (open(OUT, $self->{OUT})) {
768 $self->error("$self->{OUT} : $err");
773 print qq|Content-Type: application/$self->{format}
774 Content-Disposition: attachment; filename="$self->{tmpfile}"\n\n|;
776 unless (open(OUT, ">-")) {
779 $self->error("STDOUT : $err");
809 my ($str, $pos, $l, $item, $newstr);
813 while (/<%(.+?)%>/) {
817 foreach $item (split / /, $1) {
818 my ($key, $value) = split /=/, $item;
819 if (defined $value) {
826 $str = (defined $i) ? $self->{$var}[$i] : $self->{$var};
828 if ($a{align} || $a{width} || $a{offset}) {
830 $str =~ s/(
\r|\n)+/" " x $a{offset}/ge;
833 if ($l > $a{width}) {
834 if (($pos = rindex $str, " ", $a{width}) > 0) {
835 $newstr = substr($str, 0, $pos);
837 $str = substr($str, $pos + 1);
839 while (length $str > $a{width}) {
840 if (($pos = rindex $str, " ", $a{width}) > 0) {
841 $newstr .= (" " x $a{offset}).substr($str, 0, $pos);
843 $str = substr($str, $pos + 1);
845 $newstr .= (" " x $a{offset}).substr($str, 0, $a{width});
847 $str = substr($str, $a{width} + 1);
852 $str .= " " x ($a{width} - $l);
853 $newstr .= (" " x $a{offset}).$str;
859 # pad left, right or center
861 $l = ($a{width} - $l);
865 if ($pos eq 'right') {
869 if ($pos eq 'left') {
873 if ($pos eq 'center') {
876 $pad = " " x ($l/2 + 1) if ($l % 2);
893 chdir("$self->{tmpdir}");
896 if (-f "$self->{tmpfile}.err") {
897 open(FH, "$self->{tmpfile}.err");
902 if ($self->{tmpfile}) {
904 $self->{tmpfile} =~ s/\.\w+$//g;
905 my $tmpfile = $self->{tmpfile};
906 unlink(<$tmpfile.*>);
909 chdir("$self->{cwd}");
917 my ($self, @fields) = @_;
919 my $format = $self->{format};
920 if ($self->{format} =~ /(postscript|pdf)/) {
924 my %replace = ( 'order' => { html => [ '<', '>', quotemeta('\n'), '
\r' ],
925 txt => [ quotemeta('\n') ],
926 tex => [ '&', quotemeta('\n'), '
\r',
927 '\$', '%', '_', '#', quotemeta('^'),
928 '{', '}', '<', '>', '£',
929 quotemeta('\\\\') ] },
930 html => { '<' => '<', '>' => '>',
931 quotemeta('\n') => '<br>', '
\r' => '<br>'
933 txt => { quotemeta('\n') },
935 '&' => '\&', '\$' => '\$', '%' => '\%', '_' => '\_',
936 '#' => '\#', quotemeta('^') => '\^\\', '{' => '\{', '}' => '\}',
937 '<' => '$<$', '>' => '$>$',
938 quotemeta('\n') => '\newline ', '
\r' => '\newline ',
939 '£' => '\pounds ', quotemeta('\\\\') => '$\backslash$'
943 foreach my $key (@{ $replace{order}{$format} }) {
944 map { $self->{$_} =~ s/$key/$replace{$format}{$key}/g; } @fields;
951 my ($self, $date, $myconfig) = @_;
953 if ($date && $date =~ /\D/) {
955 if ($myconfig->{dateformat} =~ /^yy/) {
956 ($yy, $mm, $dd) = split /\D/, $date;
958 if ($myconfig->{dateformat} =~ /^mm/) {
959 ($mm, $dd, $yy) = split /\D/, $date;
961 if ($myconfig->{dateformat} =~ /^dd/) {
962 ($dd, $mm, $yy) = split /\D/, $date;
967 $yy = ($yy < 70) ? $yy + 2000 : $yy;
968 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
970 $dd = "0$dd" if ($dd < 10);
971 $mm = "0$mm" if ($mm < 10);
981 # Database routines used throughout
984 my ($self, $myconfig) = @_;
986 # connect to database
987 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}) or $self->dberror;
990 if ($myconfig->{dboptions}) {
991 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
999 sub dbconnect_noauto {
1000 my ($self, $myconfig) = @_;
1002 # connect to database
1003 $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, {AutoCommit => 0}) or $self->dberror;
1006 if ($myconfig->{dboptions}) {
1007 $dbh->do($myconfig->{dboptions});
1016 my ($self, $var, $type) = @_;
1020 # DBI does not return NULL for SQL_DATE if the date is empty, bug ?
1022 if (defined $type) {
1023 if ($type eq 'SQL_DATE') {
1024 $rv = "'$var'" if $var;
1025 } elsif ($type eq 'SQL_INT.*') {
1028 if ($type !~ /SQL_.*CHAR/) {
1046 sub update_balance {
1047 my ($self, $dbh, $table, $field, $where, $value) = @_;
1049 # if we have a value, go do it
1051 # retrieve balance from table
1052 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1053 my ($balance) = $dbh->selectrow_array($query);
1057 $query = "UPDATE $table SET $field = $balance WHERE $where";
1058 $dbh->do($query) || $self->dberror($query);
1064 sub update_exchangerate {
1065 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1067 # some sanity check for currency
1068 return if ($curr eq '');
1070 my $query = qq|SELECT curr FROM exchangerate
1071 WHERE curr = '$curr'
1072 AND transdate = '$transdate'
1074 my $sth = $dbh->prepare($query);
1075 $sth->execute || $self->dberror($query);
1078 if ($buy != 0 && $sell != 0) {
1079 $set = "buy = $buy, sell = $sell";
1080 } elsif ($buy != 0) {
1081 $set = "buy = $buy";
1082 } elsif ($sell != 0) {
1083 $set = "sell = $sell";
1086 if ($sth->fetchrow_array) {
1087 $query = qq|UPDATE exchangerate
1089 WHERE curr = '$curr'
1090 AND transdate = '$transdate'|;
1092 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1093 VALUES ('$curr', $buy, $sell, '$transdate')|;
1096 $dbh->do($query) || $self->dberror($query);
1101 sub save_exchangerate {
1102 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1104 my $dbh = $self->dbconnect($myconfig);
1106 my ($buy, $sell) = (0, 0);
1107 $buy = $rate if $fld eq 'buy';
1108 $sell = $rate if $fld eq 'sell';
1110 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1117 sub get_exchangerate {
1118 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1120 my $query = qq|SELECT $fld FROM exchangerate
1121 WHERE curr = '$curr'
1122 AND transdate = '$transdate'|;
1123 my ($exchangerate) = $dbh->selectrow_array($query);
1130 sub check_exchangerate {
1131 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1133 return "" unless $transdate;
1135 my $dbh = $self->dbconnect($myconfig);
1137 my $query = qq|SELECT $fld FROM exchangerate
1138 WHERE curr = '$currency'
1139 AND transdate = '$transdate'|;
1140 my ($exchangerate) = $dbh->selectrow_array($query);
1150 my ($self, $dbh, $id) = @_;
1153 foreach my $item (qw(name address1 address2 city state zipcode country contact phone fax email)) {
1154 if ($self->{"shipto$item"}) {
1155 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1160 my $query = qq|INSERT INTO shipto (trans_id, shiptoname, shiptoaddress1,
1161 shiptoaddress2, shiptocity, shiptostate,
1162 shiptozipcode, shiptocountry, shiptocontact,
1163 shiptophone, shiptofax, shiptoemail) VALUES ($id, |
1164 .$dbh->quote($self->{shiptoname}).qq|, |
1165 .$dbh->quote($self->{shiptoaddress1}).qq|, |
1166 .$dbh->quote($self->{shiptoaddress2}).qq|, |
1167 .$dbh->quote($self->{shiptocity}).qq|, |
1168 .$dbh->quote($self->{shiptostate}).qq|, |
1169 .$dbh->quote($self->{shiptozipcode}).qq|, |
1170 .$dbh->quote($self->{shiptocountry}).qq|, |
1171 .$dbh->quote($self->{shiptocontact}).qq|,
1172 '$self->{shiptophone}', '$self->{shiptofax}',
1173 '$self->{shiptoemail}')|;
1174 $dbh->do($query) || $self->dberror($query);
1181 my ($self, $dbh) = @_;
1183 my $login = $self->{login};
1185 my $query = qq|SELECT name, id FROM employee
1186 WHERE login = '$login'|;
1187 my (@a) = $dbh->selectrow_array($query);
1195 # this sub gets the id and name from $table
1197 my ($self, $myconfig, $table) = @_;
1199 # connect to database
1200 my $dbh = $self->dbconnect($myconfig);
1202 my $name = $self->like(lc $self->{$table});
1203 my $query = qq~SELECT c.id, c.name, c.address1, c.address2,
1204 c.city, c.state, c.zipcode, c.country
1206 WHERE lower(c.name) LIKE '$name'
1209 if ($self->{openinvoices}) {
1210 $query = qq~SELECT DISTINCT c.id, c.name, c.address1, c.address2,
1211 c.city, c.state, c.zipcode, c.country
1212 FROM $self->{arap} a
1213 JOIN $table c ON (a.${table}_id = c.id)
1214 WHERE a.amount != a.paid
1215 AND lower(c.name) LIKE '$name'
1219 my $sth = $dbh->prepare($query);
1221 $sth->execute || $self->dberror($query);
1224 @{ $self->{name_list} } = ();
1225 while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1226 push(@{ $self->{name_list} }, $ref);
1237 # the selection sub is used in the AR, AP, IS, IR and OE module
1240 my ($self, $myconfig, $table, $module, $dbh, $enddate) = @_;
1244 if (! defined $dbh) {
1245 $dbh = $self->dbconnect($myconfig);
1250 my $query = qq|SELECT count(*) FROM $table|;
1253 if (defined $enddate) {
1254 $where = qq|AND (enddate IS NULL OR enddate >= '$enddate')|;
1255 $query .= qq| WHERE 1=1
1258 my ($count) = $dbh->selectrow_array($query);
1260 # build selection list
1261 if ($count < $myconfig->{vclimit}) {
1262 $query = qq|SELECT id, name
1267 $sth = $dbh->prepare($query);
1268 $sth->execute || $self->dberror($query);
1270 while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1271 push @{ $self->{"all_$table"} }, $ref;
1279 if (! $self->{employee_id}) {
1280 ($self->{employee}, $self->{employee_id}) = split /--/, $self->{employee};
1281 ($self->{employee}, $self->{employee_id}) = $self->get_employee($dbh) unless $self->{employee_id};
1284 # setup sales contacts
1285 $query = qq|SELECT id, name
1290 $sth = $dbh->prepare($query);
1291 $sth->execute || $self->dberror($query);
1293 while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1294 push @{ $self->{all_employees} }, $ref;
1299 if ($module eq 'AR') {
1300 # prepare query for departments
1301 $query = qq|SELECT id, description
1307 $query = qq|SELECT id, description
1312 $sth = $dbh->prepare($query);
1313 $sth->execute || $self->dberror($query);
1315 while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1316 push @{ $self->{all_departments} }, $ref;
1322 $query = qq|SELECT *
1324 ORDER BY projectnumber|;
1325 $sth = $dbh->prepare($query);
1326 $sth->execute || $self->dberror($query);
1328 $self->{all_projects} = ();
1329 while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1330 push @{ $self->{all_projects} }, $ref;
1334 # get language codes
1335 $query = qq|SELECT *
1338 $sth = $dbh->prepare($query);
1339 $sth->execute || $self->dberror($query);
1341 $self->{all_languages} = ();
1342 while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1343 push @{ $self->{all_languages} }, $ref;
1347 $self->all_years($dbh, $myconfig);
1349 $dbh->disconnect if $closedb;
1354 # this is only used for reports
1356 my ($self, $myconfig) = @_;
1358 my $dbh = $self->dbconnect($myconfig);
1360 my $query = qq|SELECT *
1362 ORDER BY projectnumber|;
1363 $sth = $dbh->prepare($query);
1364 $sth->execute || $self->dberror($query);
1366 $self->{all_projects} = ();
1367 while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1368 push @{ $self->{all_projects} }, $ref;
1377 sub all_departments {
1378 my ($self, $myconfig, $table) = @_;
1380 my $dbh = $self->dbconnect($myconfig);
1381 my $where = "1 = 1";
1383 if (defined $table) {
1384 if ($table eq 'customer') {
1385 $where = " role = 'P'";
1389 my $query = qq|SELECT id, description
1393 my $sth = $dbh->prepare($query);
1394 $sth->execute || $self->dberror($query);
1396 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) {
1397 push @{ $self->{all_departments} }, $ref;
1401 $self->all_years($dbh, $myconfig);
1409 my ($self, $dbh, $myconfig) = @_;
1412 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
1413 (SELECT MAX(transdate) FROM acc_trans)
1415 my ($startdate, $enddate) = $dbh->selectrow_array($query);
1417 if ($myconfig->{dateformat} =~ /^yy/) {
1418 ($startdate) = split /\W/, $startdate;
1419 ($enddate) = split /\W/, $enddate;
1421 (@_) = split /\W/, $startdate;
1423 (@_) = split /\W/, $enddate;
1427 while ($enddate >= $startdate) {
1428 push @{ $self->{all_years} }, $enddate--;
1431 %{ $self->{all_month} } = ( '01' => 'January',
1439 '09' => 'September',
1442 '12' => 'December' );
1448 my ($self, $module, $myconfig, $table) = @_;
1450 # get last customers or vendors
1453 my $dbh = $self->dbconnect($myconfig);
1458 # now get the account numbers
1459 $query = qq|SELECT accno, description, link
1461 WHERE link LIKE '%$module%'
1463 $sth = $dbh->prepare($query);
1464 $sth->execute || $self->dberror($query);
1466 $self->{accounts} = "";
1467 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) {
1469 foreach my $key (split /:/, $ref->{link}) {
1470 if ($key =~ /$module/) {
1471 # cross reference for keys
1472 $xkeyref{$ref->{accno}} = $key;
1474 push @{ $self->{"${module}_links"}{$key} }, { accno => $ref->{accno},
1475 description => $ref->{description} };
1477 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
1484 my $arap = ($table eq 'customer') ? 'ar' : 'ap';
1486 $query = qq|SELECT a.invnumber, a.transdate,
1487 a.${table}_id, a.datepaid, a.duedate, a.ordnumber,
1488 a.taxincluded, a.curr AS currency, a.notes, a.intnotes,
1489 c.name AS $table, a.department_id, d.description AS department,
1490 a.amount AS oldinvtotal, a.paid AS oldtotalpaid,
1491 a.employee_id, e.name AS employee, c.language_code
1493 JOIN $table c ON (a.${table}_id = c.id)
1494 LEFT JOIN employee e ON (e.id = a.employee_id)
1495 LEFT JOIN department d ON (d.id = a.department_id)
1496 WHERE a.id = $self->{id}|;
1497 $sth = $dbh->prepare($query);
1498 $sth->execute || $self->dberror($query);
1500 $ref = $sth->fetchrow_hashref(NAME_lc);
1501 foreach $key (keys %$ref) {
1502 $self->{$key} = $ref->{$key};
1507 # get printed, emailed
1508 $query = qq|SELECT s.printed, s.emailed, s.spoolfile, s.formname
1510 WHERE s.trans_id = $self->{id}|;
1511 $sth = $dbh->prepare($query);
1512 $sth->execute || $form->dberror($query);
1514 while ($ref = $sth->fetchrow_hashref(NAME_lc)) {
1515 $self->{printed} .= "$ref->{formname} " if $ref->{printed};
1516 $self->{emailed} .= "$ref->{formname} " if $ref->{emailed};
1517 $self->{queued} .= "$ref->{formname} $ref->{spoolfile} " if $ref->{spoolfile};
1520 map { $self->{$_} =~ s/ +$//g } qw(printed emailed queued);
1523 # get amounts from individual entries
1524 $query = qq|SELECT c.accno, c.description, a.source, a.amount, a.memo,
1525 a.transdate, a.cleared, a.project_id, p.projectnumber
1527 JOIN chart c ON (c.id = a.chart_id)
1528 LEFT JOIN project p ON (p.id = a.project_id)
1529 WHERE a.trans_id = $self->{id}
1530 AND a.fx_transaction = '0'
1531 ORDER BY transdate|;
1532 $sth = $dbh->prepare($query);
1533 $sth->execute || $self->dberror($query);
1536 my $fld = ($table eq 'customer') ? 'buy' : 'sell';
1538 $self->{exchangerate} = $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
1540 # store amounts in {acc_trans}{$key} for multiple accounts
1541 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) {
1542 $ref->{exchangerate} = $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
1544 push @{ $self->{acc_trans}{$xkeyref{$ref->{accno}}} }, $ref;
1548 $query = qq|SELECT d.curr AS currencies, d.closedto, d.revtrans,
1549 (SELECT c.accno FROM chart c
1550 WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
1551 (SELECT c.accno FROM chart c
1552 WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
1554 $sth = $dbh->prepare($query);
1555 $sth->execute || $self->dberror($query);
1557 $ref = $sth->fetchrow_hashref(NAME_lc);
1558 map { $self->{$_} = $ref->{$_} } keys %$ref;
1564 $query = qq|SELECT current_date AS transdate,
1565 d.curr AS currencies, d.closedto, d.revtrans,
1566 (SELECT c.accno FROM chart c
1567 WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
1568 (SELECT c.accno FROM chart c
1569 WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
1571 $sth = $dbh->prepare($query);
1572 $sth->execute || $self->dberror($query);
1574 $ref = $sth->fetchrow_hashref(NAME_lc);
1575 map { $self->{$_} = $ref->{$_} } keys %$ref;
1578 if (! $self->{"$self->{vc}_id"}) {
1579 $self->lastname_used($dbh, $myconfig, $table, $module);
1584 $self->all_vc($myconfig, $table, $module, $dbh, $self->{transdate});
1592 my ($self, $dbh, $myconfig, $table, $module) = @_;
1594 my $arap = ($table eq 'customer') ? "ar" : "ap";
1595 my $where = "1 = 1";
1598 if ($self->{type} =~ /_order/) {
1600 $where = "quotation = '0'";
1602 if ($self->{type} =~ /_quotation/) {
1604 $where = "quotation = '1'";
1607 my $query = qq|SELECT id FROM $arap
1608 WHERE id IN (SELECT MAX(id) FROM $arap
1610 AND ${table}_id > 0)|;
1611 my ($trans_id) = $dbh->selectrow_array($query);
1615 my $DAYS = ($myconfig->{dbdriver} eq 'DB2') ? "DAYS" : "";
1617 $query = qq|SELECT ct.name AS $table, a.curr AS currency, a.${table}_id,
1618 current_date + ct.terms $DAYS AS duedate, a.department_id,
1619 d.description AS department, ct.notes, ct.curr AS currency
1621 JOIN $table ct ON (a.${table}_id = ct.id)
1622 LEFT JOIN department d ON (a.department_id = d.id)
1623 WHERE a.id = $trans_id|;
1624 $sth = $dbh->prepare($query);
1625 $sth->execute || $self->dberror($query);
1627 my $ref = $sth->fetchrow_hashref(NAME_lc);
1628 map { $self->{$_} = $ref->{$_} } keys %$ref;
1636 my ($self, $myconfig, $thisdate, $days) = @_;
1638 my $dbh = $self->dbconnect($myconfig);
1643 my $dateformat = $myconfig->{dateformat};
1644 if ($myconfig->{dateformat} !~ /^y/) {
1645 my @a = split /\D/, $thisdate;
1646 $dateformat .= "yy" if (length $a[2] > 2);
1649 if ($thisdate !~ /\D/) {
1650 $dateformat = 'yyyymmdd';
1653 if ($myconfig->{dbdriver} eq 'DB2') {
1654 $query = qq|SELECT date('$thisdate') + $days DAYS AS thisdate
1657 $query = qq|SELECT to_date('$thisdate', '$dateformat') + $days AS thisdate
1661 $sth = $dbh->prepare($query);
1662 $sth->execute || $self->dberror($query);
1664 $query = qq|SELECT current_date AS thisdate
1666 $sth = $dbh->prepare($query);
1667 $sth->execute || $self->dberror($query);
1670 ($thisdate) = $sth->fetchrow_array;
1681 my ($self, $str) = @_;
1683 if ($str !~ /(%|_)/) {
1694 my ($self, $flds, $new, $count, $numrows) = @_;
1698 map { push @ndx, { num => $new->[$_-1]->{runningnumber}, ndx => $_ } } (1 .. $count);
1702 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
1704 $j = $item->{ndx} - 1;
1705 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
1709 for $i ($count + 1 .. $numrows) {
1710 map { delete $self->{"${_}_$i"} } @{$flds};
1716 sub get_partsgroup {
1717 my ($self, $myconfig, $p) = @_;
1719 my $dbh = $self->dbconnect($myconfig);
1721 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
1723 JOIN parts p ON (p.partsgroup_id = pg.id)|;
1725 if ($p->{searchitems} eq 'part') {
1727 WHERE p.inventory_accno_id > 0|;
1729 if ($p->{searchitems} eq 'service') {
1731 WHERE p.inventory_accno_id IS NULL|;
1733 if ($p->{searchitems} eq 'assembly') {
1735 WHERE p.assembly = '1'|;
1737 if ($p->{searchitems} eq 'labor') {
1739 WHERE p.inventory_accno_id > 0 AND p.income_accno_id IS NULL|;
1743 ORDER BY partsgroup|;
1746 $query = qq|SELECT id, partsgroup FROM partsgroup
1747 ORDER BY partsgroup|;
1750 if ($p->{language_code}) {
1751 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
1752 t.description AS translation
1754 JOIN parts p ON (p.partsgroup_id = pg.id)
1755 LEFT JOIN translation t ON (t.trans_id = pg.id AND t.language_code = '$p->{language_code}')
1756 ORDER BY translation|;
1759 my $sth = $dbh->prepare($query);
1760 $sth->execute || $self->dberror($query);
1762 $self->{all_partsgroup} = ();
1763 while (my $ref = $sth->fetchrow_hashref(NAME_lc)) {
1764 push @{ $self->{all_partsgroup} }, $ref;
1773 my ($self, $myconfig) = @_;
1776 return unless $self->{id};
1781 my $dbh = $self->dbconnect_noauto($myconfig);
1783 my $query = qq|DELETE FROM status
1784 WHERE formname = |.$dbh->quote($self->{formname}).qq|
1786 my $sth = $dbh->prepare($query) || $self->dberror($query);
1788 if ($self->{formname} =~ /(check|receipt)/) {
1789 for $i (1 .. $self->{rowcount}) {
1790 $sth->execute($self->{"id_$i"} * 1) || $self->dberror($query);
1794 $sth->execute($self->{id}) || $self->dberror($query);
1798 my $printed = ($self->{printed} =~ /$self->{formname}/) ? "1" : "0";
1799 my $emailed = ($self->{emailed} =~ /$self->{formname}/) ? "1" : "0";
1801 my %queued = split / /, $self->{queued};
1803 if ($self->{formname} =~ /(check|receipt)/) {
1804 # this is a check or receipt, add one entry for each lineitem
1805 my ($accno) = split /--/, $self->{account};
1806 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname,
1807 chart_id) VALUES (?, '$printed',|
1808 .$dbh->quote($queued{$self->{formname}}).qq|, |
1809 .$dbh->quote($self->{formname}).qq|,
1810 (SELECT id FROM chart WHERE accno = |
1811 .$dbh->quote($accno).qq|))|;
1812 $sth = $dbh->prepare($query) || $self->dberror($query);
1814 for $i (1 .. $self->{rowcount}) {
1815 if ($self->{"checked_$i"}) {
1816 $sth->execute($self->{"id_$i"}) || $self->dberror($query);
1821 $query = qq|INSERT INTO status (trans_id, printed, emailed,
1822 spoolfile, formname)
1823 VALUES ($self->{id}, '$printed', '$emailed', |
1824 .$dbh->quote($queued{$self->{formname}}).qq|, |
1825 .$dbh->quote($self->{formname}).qq|)|;
1826 $dbh->do($query) || $self->dberror($query);
1836 my ($self, $dbh) = @_;
1838 my ($query, $printed, $emailed);
1840 my $formnames = $self->{printed};
1841 my $emailforms = $self->{emailed};
1843 my $query = qq|DELETE FROM status
1844 WHERE formname = '$self->{formname}'
1845 AND trans_id = $self->{id}|;
1846 $dbh->do($query) || $self->dberror($query);
1848 if ($self->{queued}) {
1849 $query = qq|DELETE FROM status
1850 WHERE spoolfile IS NOT NULL
1851 AND trans_id = $self->{id}|;
1852 $dbh->do($query) || $self->dberror($query);
1854 my %queued = split / /, $self->{queued};
1856 foreach my $formname (keys %queued) {
1857 $printed = ($self->{printed} =~ /$self->{formname}/) ? "1" : "0";
1858 $emailed = ($self->{emailed} =~ /$self->{formname}/) ? "1" : "0";
1860 $query = qq|INSERT INTO status (trans_id, printed, emailed,
1861 spoolfile, formname)
1862 VALUES ($self->{id}, '$printed', '$emailed',
1863 '$queued{$formname}', '$formname')|;
1864 $dbh->do($query) || $self->dberror($query);
1865 $formnames =~ s/$formname//;
1866 $emailforms =~ s/$formname//;
1871 # save printed, emailed info
1872 $formnames =~ s/^ +//g;
1873 $emailforms =~ s/^ +//g;
1876 map { $status{$_}{printed} = 1 } split / +/, $formnames;
1877 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
1879 foreach my $formname (keys %status) {
1880 $printed = ($formnames =~ /$self->{formname}/) ? "1" : "0";
1881 $emailed = ($emailforms =~ /$self->{formname}/) ? "1" : "0";
1883 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
1884 VALUES ($self->{id}, '$printed', '$emailed', '$formname')|;
1885 $dbh->do($query) || $self->dberror($query);
1892 my ($self, $myconfig, $table) = @_;
1895 return unless $self->{id};
1897 my $dbh = $self->dbconnect($myconfig);
1899 my $query = qq|UPDATE $table SET
1900 intnotes = |.$dbh->quote($self->{intnotes}).qq|
1901 WHERE id = $self->{id}|;
1902 $dbh->do($query) || $self->dberror($query);
1909 sub update_defaults {
1910 my ($self, $myconfig, $fld, $dbh) = @_;
1914 if (! defined $dbh) {
1915 $dbh = $self->dbconnect_noauto($myconfig);
1919 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
1920 ($_) = $dbh->selectrow_array($query);
1924 # check for and replace
1925 # <%DATE%>, <%YYMMDD%> or variations of
1926 # <%NAME 1 1 3%>, <%BUSINESS%>, <%BUSINESS 10%>, <%CURR...%>
1927 # <%DESCRIPTION 1 1 3%>, <%ITEM 1 1 3%>, <%PARTSGROUP 1 1 3%> only for parts
1928 # <%PHONE%> for customer and vendors
1931 $num =~ s/(<%.*?%>)//g;
1932 ($num) = $num =~ /(\d+)/;
1935 # if we have leading zeros check how long it is
1937 my $l = length $num;
1939 $l -= length $incnum;
1941 # pad it out with zeros
1942 my $padzero = "0" x $l;
1943 $incnum = ("0" x $l) . $incnum;
1963 if ($param =~ /<%date%>/i) {
1964 $str = ($self->split_date($myconfig->{dateformat}, $self->{transdate}))[0];
1965 $var =~ s/$param/$str/;
1968 if ($param =~ /<%(name|business|description|item|partsgroup|phone|custom)/i) {
1971 if ($fld =~ /name/) {
1972 if ($self->{type}) {
1979 my @p = split / /, $p;
1980 my @n = split / /, uc $self->{$fld};
1982 for (my $i = 1; $i <= $#p; $i++) {
1983 $str .= substr($n[$i-1], 0, $p[$i]);
1986 ($str) = split /--/, $self->{$fld};
1988 $var =~ s/$param/$str/;
1990 $var =~ s/\W//g if $fld eq 'phone';
1993 if ($param =~ /<%(yy|mm|dd)/i) {
1998 $spc = substr($spc, 0, 1);
1999 my %d = ( yy => 1, mm => 2, dd => 3 );
2002 my @a = $self->split_date($myconfig->{dateformat}, $self->{transdate});
2003 map { push @p, $a[$d{$_}] if ($p =~ /$_/) } sort keys %d;
2004 $str = join $spc, @p;
2006 $var =~ s/$param/$str/;
2009 if ($param =~ /<%curr/i) {
2010 $var =~ s/$param/$self->{currency}/;
2016 $query = qq|UPDATE defaults
2017 SET $fld = '$dbvar'|;
2018 $dbh->do($query) || $form->dberror($query);
2031 my ($self, $dateformat, $date) = @_;
2042 $yy = substr($d[5],-2);
2045 $mm = "0$mm" if $mm < 10;
2046 $dd = "0$dd" if $dd < 10;
2049 if ($dateformat =~ /^yy/) {
2051 if ($date =~ /\D/) {
2052 ($yy, $mm, $dd) = split /\D/, $date;
2055 $mm = "0$mm" if $mm < 10;
2056 $dd = "0$dd" if $dd < 10;
2057 $yy = substr($yy, -2);
2067 if ($dateformat =~ /^mm/) {
2069 if ($date =~ /\D/) {
2070 ($mm, $dd, $yy) = split /\D/, $date if $date;
2073 $mm = "0$mm" if $mm < 10;
2074 $dd = "0$dd" if $dd < 10;
2075 $yy = substr($yy, -2);
2085 if ($dateformat =~ /^dd/) {
2087 if ($date =~ /\D/) {
2088 ($dd, $mm, $yy) = split /\D/, $date if $date;
2091 $mm = "0$mm" if $mm < 10;
2092 $dd = "0$dd" if $dd < 10;
2093 $yy = substr($yy, -2);
2103 ($rv, $yy, $mm, $dd);
2109 my ($self, $yy, $mm, $interval) = @_;
2115 my $fromdate = "$yy${mm}01";
2118 if (defined $interval) {
2119 if ($interval == 12) {
2122 if (($mm += $interval) > 12) {
2126 if ($interval == 0) {
2127 @t = localtime(time);
2142 @t = localtime(timelocal(0,0,0,$dd,$mm,$yy) - $bd);
2145 $t[4] = substr("0$t[4]",-2);
2146 $t[3] = substr("0$t[3]",-2);
2148 ($fromdate, "$yy$t[4]$t[3]");
2154 my ($self, $dbh, $myconfig, $audittrail) = @_;
2156 # table, $reference, $formname, $action, $id, $transdate) = @_;
2161 # if we have an id add audittrail, otherwise get a new timestamp
2163 if ($audittrail->{id}) {
2164 $dbh = $self->dbconnect($myconfig) if $myconfig;
2166 $query = qq|SELECT audittrail FROM defaults|;
2168 if ($dbh->selectrow_array($query)) {
2169 my ($null, $employee_id) = $self->get_employee($dbh);
2171 if ($self->{audittrail} && !$myconfig) {
2172 chop $self->{audittrail};
2174 my @a = split /\|/, $self->{audittrail};
2178 my @flds = qw(tablename reference formname action transdate);
2180 # put into hash and remove dups
2182 $key = "$a[2]$a[3]";
2184 $newtrail{$key} = { map { $_ => $a[$i++] } @flds };
2188 $query = qq|INSERT INTO audittrail (trans_id, tablename, reference,
2189 formname, action, employee_id, transdate)
2190 VALUES ($audittrail->{id}, ?, ?,
2191 ?, ?, $employee_id, ?)|;
2192 my $sth = $dbh->prepare($query) || $self->dberror($query);
2194 foreach $key (sort { $newtrail{$a}{transdate} cmp $newtrail{$b}{transdate} } keys %newtrail) {
2196 map { $sth->bind_param($i++, $newtrail{$key}{$_}) } @flds;
2198 $sth->execute || $self->dberror;
2204 if ($audittrail->{transdate}) {
2205 $query = qq|INSERT INTO audittrail (trans_id, tablename, reference,
2206 formname, action, employee_id, transdate) VALUES (
2207 $audittrail->{id}, '$audittrail->{tablename}', |
2208 .$dbh->quote($audittrail->{reference}).qq|',
2209 '$audittrail->{formname}', '$audittrail->{action}',
2210 $employee_id, '$audittrail->{transdate}')|;
2212 $query = qq|INSERT INTO audittrail (trans_id, tablename, reference,
2213 formname, action, employee_id) VALUES ($audittrail->{id},
2214 '$audittrail->{tablename}', |
2215 .$dbh->quote($audittrail->{reference}).qq|,
2216 '$audittrail->{formname}', '$audittrail->{action}',
2222 $dbh = $self->dbconnect($myconfig);
2224 $query = qq|SELECT current_timestamp FROM defaults|;
2225 my ($timestamp) = $dbh->selectrow_array($query);
2227 $rv = "$audittrail->{tablename}|$audittrail->{reference}|$audittrail->{formname}|$audittrail->{action}|$timestamp|";
2230 $dbh->disconnect if $myconfig;
2242 my ($type, $country, $NLS_file) = @_;
2246 if ($country && -d "locale/$country") {
2247 $self->{countrycode} = $country;
2248 eval { require "locale/$country/$NLS_file"; };
2251 $self->{NLS_file} = $NLS_file;
2253 push @{ $self->{LONG_MONTH} }, ("January", "February", "March", "April", "May ", "June", "July", "August", "September", "October", "November", "December");
2254 push @{ $self->{SHORT_MONTH} }, (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec));
2262 my ($self, $text) = @_;
2264 return (exists $self{texts}{$text}) ? $self{texts}{$text} : $text;
2270 my ($self, $text) = @_;
2272 if (exists $self{subs}{$text}) {
2273 $text = $self{subs}{$text};
2275 if ($self->{countrycode} && $self->{NLS_file}) {
2276 Form->error("$text not defined in locale/$self->{countrycode}/$self->{NLS_file}");
2286 my ($self, $myconfig, $date, $longformat) = @_;
2289 my $longmonth = ($longformat) ? 'LONG_MONTH' : 'SHORT_MONTH';
2294 $spc = $myconfig->{dateformat};
2296 $spc = substr($spc, 0, 1);
2298 if ($date =~ /\D/) {
2299 if ($myconfig->{dateformat} =~ /^yy/) {
2300 ($yy, $mm, $dd) = split /\D/, $date;
2302 if ($myconfig->{dateformat} =~ /^mm/) {
2303 ($mm, $dd, $yy) = split /\D/, $date;
2305 if ($myconfig->{dateformat} =~ /^dd/) {
2306 ($dd, $mm, $yy) = split /\D/, $date;
2309 $date = substr($date, 2);
2310 ($yy, $mm, $dd) = ($date =~ /(..)(..)(..)/);
2315 $yy = ($yy < 70) ? $yy + 2000 : $yy;
2316 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
2318 if ($myconfig->{dateformat} =~ /^dd/) {
2320 $dd = "0$dd" if ($dd < 10);
2321 $mm = "0$mm" if ($mm < 10);
2322 $longdate = "$dd$spc$mm$spc$yy";
2324 if (defined $longformat) {
2326 $longdate .= ($spc eq '.') ? ". " : " ";
2327 $longdate .= &text($self, $self->{$longmonth}[--$mm])." $yy";
2329 } elsif ($myconfig->{dateformat} =~ /^yy/) {
2331 $dd = "0$dd" if ($dd < 10);
2332 $mm = "0$mm" if ($mm < 10);
2333 $longdate = "$yy$spc$mm$spc$dd";
2335 if (defined $longformat) {
2336 $longdate = &text($self, $self->{$longmonth}[--$mm])." $dd $yy";
2340 $dd = "0$dd" if ($dd < 10);
2341 $mm = "0$mm" if ($mm < 10);
2342 $longdate = "$mm$spc$dd$spc$yy";
2344 if (defined $longformat) {
2345 $longdate = &text($self, $self->{$longmonth}[--$mm])." $dd $yy";