=head1 NAME Form =head1 SYNOPSIS This module provides general legacy support functions and the central object =head1 STATUS Deprecated =head1 COPYRIGHT #==================================================================== # LedgerSMB # Small Medium Business Accounting software # http://www.ledgersmb.org/ # # Copyright (C) 2006 # This work contains copyrighted information from a number of sources # all used with permission. # # This file contains source code included with or based on SQL-Ledger # which is Copyright Dieter Simader and DWS Systems Inc. 2000-2005 # and licensed under the GNU General Public License version 2 or, at # your option, any later version. For a full list including contact # information of contributors, maintainers, and copyright holders, # see the CONTRIBUTORS file. # # Original Copyright Notice from SQL-Ledger 2.6.17 (before the fork): # Copyright (C) 2000 # # Author: DWS Systems Inc. # Web: http://www.sql-ledger.org # # Contributors: Thomas Bayen # Antti Kaihola # Moritz Bunkus (tex) # Jim Rawlings (DB2) #==================================================================== # # This file has undergone whitespace cleanup. # #==================================================================== # # main package # #==================================================================== =head1 METHODS =over =cut #inline documentation use strict; use Math::BigFloat lib => 'GMP'; use LedgerSMB::Sysconfig; use List::Util qw(first); use LedgerSMB::Mailer; use Time::Local; use Cwd; use File::Copy; use charnames ':full'; use open ':utf8'; package Form; =item new Form([$argstr]) Returns a reference to new Form object. The initial set of attributes is obtained from $argstr, a CGI query string, or $ARGV[0]. All the values are run through unescape to undo any URI encoding. The version and dbversion attributes are set to hardcoded values; action, nextsub, path, script, and login are filtered to remove some dangerous values. Both menubar and lynx are set if path matches lynx. $form->error may be called to deny access on some attribute values. =cut sub new { my $type = shift; my $argstr = shift; read( STDIN, $_, $ENV{CONTENT_LENGTH} ); if ($argstr) { $_ = $argstr; } elsif ( $ENV{QUERY_STRING} ) { $_ = $ENV{QUERY_STRING}; } elsif ( $ARGV[0] ) { $_ = $ARGV[0]; } my $self = {}; %$self = split /[&=]/; for ( keys %$self ) { $self->{$_} = unescape( "", $self->{$_} ) } if ( substr( $self->{action}, 0, 1 ) !~ /( |\.)/ ) { $self->{action} = lc $self->{action}; $self->{action} =~ s/( |-|,|\#|\/|\.$)/_/g; $self->{nextsub} = lc $self->{nextsub}; $self->{nextsub} =~ s/( |-|,|\#|\/|\.$)/_/g; } $self->{login} =~ s/[^a-zA-Z0-9._+\@'-]//g; if (!$self->{company} && $ENV{HTTP_COOKIE}){ $ENV{HTTP_COOKIE} =~ s/;\s*/;/g; my %cookie; my @cookies = split /;/, $ENV{HTTP_COOKIE}; foreach (@cookies) { my ( $name, $value ) = split /=/, $_, 2; $cookie{$name} = $value; } my $ccookie = $cookie{LedgerSMB}; $ccookie =~ s/.*:([^:]*)$/$1/; $self->{company} = $ccookie; } $self->{menubar} = 1 if $self->{path} =~ /lynx/i; #menubar will be deprecated, replaced with below $self->{lynx} = 1 if $self->{path} =~ /lynx/i; $self->{version} = "SVN Trunk"; $self->{dbversion} = "1.2.0"; bless $self, $type; if ( $self->{path} ne 'bin/lynx' ) { $self->{path} = 'bin/mozilla'; } if ( ( $self->{script} ) and not List::Util::first { $_ eq $self->{script} } @{LedgerSMB::Sysconfig::scripts} ) { $self->error( 'Access Denied', __LINE__, __FILE__ ); } if ( ( $self->{action} =~ /(:|')/ ) || ( $self->{nextsub} =~ /(:|')/ ) ) { $self->error( "Access Denied", __LINE__, __FILE__ ); } for ( keys %$self ) { $self->{$_} =~ s/\N{NULL}//g } if ( ($self->{action} eq 'redirect') || ($self->{nextsub} eq 'redirect') ) { $self->error( "Access Denied", __LINE__, __FILE__ ); } $self; } =item $form->debug([$file]); Outputs the sorted contents of $form. If a filename is specified, log to it, otherwise output to STDOUT. =cut sub debug { my ( $self, $file ) = @_; if ($file) { open( FH, '>', "$file" ) or die $!; for ( sort keys %$self ) { print FH "$_ = $self->{$_}\n" } close(FH); } else { print "\n"; for ( sort keys %$self ) { print "$_ = $self->{$_}\n" } } } =item $form->encode_all(); Does nothing and is unused. Contains merely the comment # TODO; =cut sub encode_all { # TODO; } =item $form->decode_all(); Does nothing and is unused. Contains merely the comment # TODO =cut sub decode_all { # TODO } =item $form->escape($str[, $beenthere]); Returns the URI-encoded $str. $beenthere is a boolean that when true forces a single encoding run. When false, it escapes the string twice if it detects that it is running on a version of Apache 2.0 earlier than 2.0.44. Note that recurring transaction support depends on this function escaping ','. =cut sub escape { my ( $self, $str, $beenthere ) = @_; # for Apache 2 we escape strings twice if ( ( $ENV{SERVER_SIGNATURE} =~ /Apache\/2\.(\d+)\.(\d+)/ ) && !$beenthere ) { $str = $self->escape( $str, 1 ) if $1 == 0 && $2 < 44; } utf8::encode($str); # SC: Adding commas to the ignore list will break recurring transactions $str =~ s/([^a-zA-Z0-9_.-])/sprintf("%%%02x", ord($1))/ge; $str; } =item $form->unescape($str); Returns the unencoded form of the URI-encoded $str. =cut sub unescape { my ( $self, $str ) = @_; $str =~ tr/+/ /; $str =~ s/\\$//; utf8::encode($str) if utf8::is_utf8($str); $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg; utf8::decode($str); $str =~ s/\r?\n/\n/g; $str; } =item $form->quote($str); Replaces all double quotes in $str with '"'. Does nothing if $str is a reference. =cut sub quote { my ( $self, $str ) = @_; if ( $str && !ref($str) ) { $str =~ s/"/"/g; } $str; } =item $form->unquote($str); Replaces all '"' in $str with double quotes. Does nothing if $str is a reference. =cut sub unquote { my ( $self, $str ) = @_; if ( $str && !ref($str) ) { $str =~ s/"/"/g; } $str; } =item $form->hide_form([...]); Outputs hidden HTML form fields to STDOUT. If values are passed into this function, only those $form values are output. If no values are passed in, all $form values are output as well as deleting $form->{header}. Values from the $form object are run through $form->quote, whereas keys/names are not. Sample output: =cut sub hide_form { my $self = shift; if (@_) { for (@_) { print qq|\n|; } } else { delete $self->{header}; for ( sort keys %$self ) { print qq|\n|; } } } =item $form->error($msg); Output an error message, $msg. If a CGI environment is detected, this outputs an HTTP and HTML header section if required, and displays the message after running it through $form->format_string. If it is not a CGI environment and $ENV{error_function} is set, call the specified function with $msg as the sole argument. Otherwise, this function simply dies with $msg. This function does not return. Execution is terminated at the end of the appropriate path. =cut sub error { my ( $self, $msg ) = @_; if ( $ENV{GATEWAY_INTERFACE} ) { $self->{msg} = $msg; $self->{format} = "html"; $self->format_string('msg'); delete $self->{pre}; if ( !$self->{header} ) { $self->header; } print qq|

Error!

$self->{msg}|; exit; } else { if ( $ENV{error_function} ) { __PACKAGE__->can($ENV{error_function})->($msg); } die "Error: $msg\n"; } } =item $form->info($msg); Output an informational message, $msg. If a CGI environment is detected, this outputs an HTTP and HTML header section if required, and displays the message in bold tags without escaping. If it is not a CGI environment and $ENV{info_function} is set, call the specified function with $msg as the sole argument. Otherwise, this function simply prints $msg to STDOUT. =cut sub info { my ( $self, $msg ) = @_; if ( $ENV{GATEWAY_INTERFACE} ) { $msg =~ s/\n/
/g; delete $self->{pre}; if ( !$self->{header} ) { $self->header; print qq| |; $self->{header} = 1; } print "$msg"; } else { if ( $ENV{info_function} ) { __PACKAGE__->can($ENV{info_function})->($msg); } else { print "$msg\n"; } } } =item $form->numtextrows($str, $cols[, $maxrows]); Returns the number of rows of $cols columns can be formed by $str. If $maxrows is set and the number of rows is greater than $maxrows, this returns $maxrows. In the determination of rowcount, newline characters, "\n", are taken into account while spaces are not. =cut sub numtextrows { my ( $self, $str, $cols, $maxrows ) = @_; my $rows = 0; for ( split /\n/, $str ) { $rows += int( ( (length) - 2 ) / $cols ) + 1; } $maxrows = $rows unless defined $maxrows; return ( $rows > $maxrows ) ? $maxrows : $rows; } =item $form->dberror($msg); Outputs a message as in $form->error but with $DBI::errstr automatically appended to $msg. =cut sub dberror { my ( $self, $msg ) = @_; $self->error( "$msg\n" . $DBI::errstr ); } =item $form->isblank($name, $msg); Calls $form->error($msg) if the value of $form->{$name} matches /^\s*$/. =cut sub isblank { my ( $self, $name, $msg ) = @_; $self->error($msg) if $self->{$name} =~ /^\s*$/; } =item $form->header([$init, $headeradd]); Outputs HTML and HTTP headers and sets $form->{header} to indicate that headers have been output. If called with $form->{header} set or in a non-CGI environment, does not output anything. $init is ignored. $headeradd is data to be added to the portion of the output headers. $form->{stylesheet}, $form->{title}, $form->{titlebar}, and $form->{pre} all affect the output of this function. If the stylesheet indicated by $form->{stylesheet} exists, output a link tag to reference it. If $form->{title} is false, the title text is the value of $form->{titlebar}. If $form->{title} is true, the title text takes the form of "$form->{title} - $form->{titlebar}". The value of $form->{pre} is output immediately after the closing of . =cut sub header { my ( $self, $init, $headeradd ) = @_; return if $self->{header}; my ( $stylesheet, $favicon, $charset ); if ( $ENV{GATEWAY_INTERFACE} ) { if ( $self->{stylesheet} && ( -f "css/$self->{stylesheet}" ) ) { $stylesheet = qq|\n|; } $self->{charset} ||= "utf-8"; $charset = qq|\n|; $self->{titlebar} = ( $self->{title} ) ? "$self->{title} - $self->{titlebar}" : $self->{titlebar}; print qq|Content-Type: text/html; charset=utf-8\n\n $self->{titlebar} $stylesheet $charset $headeradd $self->{pre} \n|; } $self->{header} = 1; } =item $form->redirect([$msg]); If $form->{callback} is set or $msg is not set, call the redirect function in common.pl. If main::redirect returns, exit. Otherwise, output $msg as an informational message with $form->info($msg). =cut sub redirect { my ( $self, $msg ) = @_; if ( $self->{callback} || !$msg ) { main::redirect(); exit; } else { $self->info($msg); } } =item $form->sort_columns(@columns); Sorts the list @columns. If $form->{sort} is unset, do nothing. If the value of $form->{sort} does not exist in @columns, returns the list formed by the value of $form->{sort} followed by the values of @columns. If the value of $form->{sort} is in @columns, return the list formed by @columns with the value of $form->{sort} moved to the head of the list. =cut sub sort_columns { my ( $self, @columns ) = @_; if ( $self->{sort} ) { $self->{sort} =~ s/^"*(.*?)"*$/$1/; if (@columns) { @columns = grep !/^$self->{sort}$/, @columns; if ($self->{sort} !~ /^\w*$/){ $self->{sort} = $self->{dbh}->quote_identifier($self->{sort}); } splice @columns, 0, 0, $self->{sort}; } } @columns; } =item $form->sort_order($columns[, $ordinal]); Returns a string that contains ordering details for the columns in SQL form. $columns is a reference to a list of columns, $ordinal is a reference to a hash that maps column names to ordinal positions. This function depends upon the values of $form->{direction}, $form->{sort}, and $form->{oldsort}. If $form->{direction} is false, it becomes 'ASC'. If $form->{direction} is true and $form->{sort} and $form->{oldsort} are equal, reverse the order specified by $form->{direction}. $form->{oldsort} is set to the same value as $form->{sort} The actual sorting of $columns happens as in $form->sort_columns(@$columns). If $ordinal is set, the positions given by it are substituted for the names of columns returned. =cut sub sort_order { my ( $self, $columns, $ordinal ) = @_; # setup direction if ( $self->{direction} ) { if ( $self->{sort} eq $self->{oldsort} ) { if ( $self->{direction} eq 'ASC' ) { $self->{direction} = "DESC"; } else { $self->{direction} = "ASC"; } } } else { $self->{direction} = "ASC"; } $self->{oldsort} = $self->{sort}; my @a = $self->sort_columns( @{$columns} ); if (ref $ordinal eq 'HASH') { $a[0] = ( $ordinal->{ $a[$_] } ) ? "$ordinal->{$a[0]} $self->{direction}" : "$a[0] $self->{direction}"; for ( 1 .. $#a ) { $a[$_] = $ordinal->{ $a[$_] } if $ordinal->{ $a[$_] }; } } else { $a[0] .= " $self->{direction}"; } my $sortorder = join ',', @a; $sortorder; } =item $form->format_amount($myconfig, $amount, $places, $dash); Returns $amount as formatted in the form specified by $form->{numberformat}. $places is the number of decimal places to have in the output. $dash indicates how to represent conditions surrounding values. +-------+----------+---------+------+ | $dash | -1.00 | 1.00 | 0.00 | +-------+----------+---------+------+ | - | (1.00) | 1.00 | - | | DRCR | 1.00 DR | 1.00 CR | DRCR | | 0 | -1.00 | 1.00 | 0.00 | | x | -1.00 | 1.00 | x | | undef | -1.00 | 1.00 | | +-------+----------+---------+------+ Sample behaviour of the formatted output of various numbers for select $dash values. =cut sub format_amount { my ( $self, $myconfig, $amount, $places, $dash ) = @_; my $negative; if ($amount) { $amount = $self->parse_amount( $myconfig, $amount ); $negative = ( $amount < 0 ); $amount =~ s/-//; } if ( $places =~ /\d+/ ) { #$places = 4 if $places == 2; $amount = $self->round_amount( $amount, $places ); } # is the amount negative # Parse $myconfig->{numberformat} my ( $ts, $ds ) = ( $1, $2 ); if ($amount) { if ( $myconfig->{numberformat} ) { my ( $whole, $dec ) = split /\./, "$amount"; $amount = join '', reverse split //, $whole; if ($places) { $dec .= "0" x $places; $dec = substr( $dec, 0, $places ); } if ( $myconfig->{numberformat} eq '1,000.00' ) { $amount =~ s/\d{3,}?/$&,/g; $amount =~ s/,$//; $amount = join '', reverse split //, $amount; $amount .= "\.$dec" if ( $dec ne "" ); } elsif ( $myconfig->{numberformat} eq '1 000.00' ) { $amount =~ s/\d{3,}?/$& /g; $amount =~ s/\s$//; $amount = join '', reverse split //, $amount; $amount .= "\.$dec" if ( $dec ne "" ); } elsif ( $myconfig->{numberformat} eq "1'000.00" ) { $amount =~ s/\d{3,}?/$&'/g; $amount =~ s/'$//; $amount = join '', reverse split //, $amount; $amount .= "\.$dec" if ( $dec ne "" ); } elsif ( $myconfig->{numberformat} eq '1.000,00' ) { $amount =~ s/\d{3,}?/$&./g; $amount =~ s/\.$//; $amount = join '', reverse split //, $amount; $amount .= ",$dec" if ( $dec ne "" ); } elsif ( $myconfig->{numberformat} eq '1000,00' ) { $amount = "$whole"; $amount .= ",$dec" if ( $dec ne "" ); } elsif ( $myconfig->{numberformat} eq '1000.00' ) { $amount = "$whole"; $amount .= ".$dec" if ( $dec ne "" ); } if ( $dash =~ /-/ ) { $amount = ($negative) ? "($amount)" : "$amount"; } elsif ( $dash =~ /DRCR/ ) { $amount = ($negative) ? "$amount DR" : "$amount CR"; } else { $amount = ($negative) ? "-$amount" : "$amount"; } } } else { if ( $dash eq "0" && $places ) { if ( $myconfig->{numberformat} =~ /0,00$/ ) { $amount = "0" . "," . "0" x $places; } else { $amount = "0" . "." . "0" x $places; } } else { $amount = ( $dash ne "" ) ? "$dash" : ""; } } $amount; } =item $form->parse_amount($myconfig, $amount); Return a Math::BigFloat containing the value of $amount where $amount is formatted as $myconfig->{numberformat}. If $amount is '' or undefined, it is treated as zero. DRCR and parenthesis notation is accepted in addition to negative sign notation. Calls $form->error if the value is NaN. =cut sub parse_amount { my ( $self, $myconfig, $amount ) = @_; if ( ( $amount eq '' ) or ( ! defined $amount ) ) { $amount = 0; } if ( UNIVERSAL::isa( $amount, 'Math::BigFloat' ) ) { # Amount may not be an object return $amount; } my $numberformat = $myconfig->{numberformat}; if ( ( $numberformat eq '1.000,00' ) || ( $numberformat eq '1000,00' ) ) { $amount =~ s/\.//g; $amount =~ s/,/./; } elsif ( $numberformat eq '1 000.00' ) { $amount =~ s/\s//g; } elsif ( $numberformat eq "1'000.00" ) { $amount =~ s/'//g; } $amount =~ s/,//g; if ( $amount =~ s/\((\d*\.?\d*)\)/$1/ ) { $amount = $1 * -1; } elsif ( $amount =~ s/(\d*\.?\d*)\s?DR/$1/ ) { $amount = $1 * -1; } $amount =~ s/\s?CR//; $amount =~ /(\d*)\.(\d*)/; my $decimalplaces = length $1 + length $2; $amount = new Math::BigFloat($amount); if ($amount->is_nan){ $self->error("Invalid number detected during parsing"); } return ( $amount * 1 ); } =item $form->round_amount($amount, $places); Rounds the provided $amount to $places decimal places. =cut sub round_amount { my ( $self, $amount, $places ) = @_; # These rounding rules follow from the previous implementation. # They should be changed to allow different rules for different accounts. Math::BigFloat->round_mode('+inf') if $amount >= 0; Math::BigFloat->round_mode('-inf') if $amount < 0; $amount = Math::BigFloat->new($amount)->ffround( -$places ) if $places >= 0; $amount = Math::BigFloat->new($amount)->ffround( -( $places - 1 ) ) if $places < 0; $amount->precision(undef); #we are assuming whole cents so do not round #immediately on arithmatic. This is necessary #because Math::BigFloat is arithmatically #correct wrt accuracy and precision. return $amount; } =item $form->db_parse_numeric('sth' => $sth, ['arrayref' => $arrayref, 'hashref' => $hashref]) Converts numeric values in the result set $arrayref or $hashref to Math::BigFloat using $sth to determine which fields are numeric. =cut sub db_parse_numeric { my $self = shift; my %args = @_; my ($sth, $arrayref, $hashref) = ($args{sth}, $args{arrayref}, $args{hashref}); my @types = @{$sth->{TYPE}}; my @names = @{$sth->{NAME_lc}}; for (0 .. $#names){ if ($types[$_] == 3){ $arrayref->[$_] = Math::BigFloat->new($arrayref->[$_]) if defined $arrayref; $hashref->{$names[$_]} = Math::BigFloat->new($hashref->{$names[$_]}) if defined $hashref; } } return ($hashref || $arrayref); } =item $form->get_my_emp_num($myconfig); Function to get the employee number of the user $form->{login}. $myconfig is only used to create %myconfig. $form->{emp_num} is set to the retrieved value. This function is currently (2007-08-02) only used by pos.conf.pl. =cut sub get_my_emp_num { my ( $self, $myconfig) = @_; my %myconfig = %{$myconfig}; my $dbh = $self->{dbh}; # we got a connection, check the version my $query = qq| SELECT employeenumber FROM employee WHERE login = ?|; my $sth = $dbh->prepare($query); $sth->execute( $self->{login} ) || $self->dberror($query); my ($id) = $sth->fetchrow_array; $sth->finish; $self->{'emp_num'} = $id; } =item $form->format_string(@fields); Escape the values of $form selected by @fields for the format specified by $form->{format}. =cut sub format_string { my ( $self, @fields ) = @_; my $format = $self->{format}; if ( $self->{format} =~ /(postscript|pdf)/ ) { $format = 'tex'; } my %replace = ( 'order' => { html => [ '<', '>', '\n', '\r' ], txt => [ '\n', '\r' ], tex => [ quotemeta('\\'), '&', '\n', '\r', '\$', '%', '_', '#', quotemeta('^'), '{', '}', '<', '>', '£' ] }, html => { '<' => '<', '>' => '>', '\n' => '
', '\r' => '
' }, txt => { '\n' => "\n", '\r' => "\r" }, tex => { '&' => '\&', '$' => '\$', '%' => '\%', '_' => '\_', '#' => '\#', quotemeta('^') => '\^\\', '{' => '\{', '}' => '\}', '<' => '$<$', '>' => '$>$', '\n' => '\newline ', '\r' => '\newline ', '£' => '\pounds ', quotemeta('\\') => '/' } ); my $key; foreach $key ( @{ $replace{order}{$format} } ) { for (@fields) { $self->{$_} =~ s/$key/$replace{$format}{$key}/g } } } =item $form->datetonum($myconfig, $date[, $picture]); Converts $date from the format $myconfig->{dateformat} to the format 'yyyymmdd'. If the year extracted is only two-digits, the year given is assumed to be in the range 2000-2099. If $date does not contain any digits, datetonum does nothing. $picture is ignored. =cut sub datetonum { my ( $self, $myconfig, $date, $picture ) = @_; if ( $date && $date =~ /\D/ ) { my $yy; my $mm; my $dd; if ( $date =~ /^\d{4}-\d\d-\d\d$/ ) { ( $yy, $mm, $dd ) = split /\D/, $date; } if ( $myconfig->{dateformat} =~ /^yy/ ) { ( $yy, $mm, $dd ) = split /\D/, $date; } elsif ( $myconfig->{dateformat} =~ /^mm/ ) { ( $mm, $dd, $yy ) = split /\D/, $date; } elsif ( $myconfig->{dateformat} =~ /^dd/ ) { ( $dd, $mm, $yy ) = split /\D/, $date; } $dd *= 1; $mm *= 1; $yy += 2000 if length $yy == 2; $dd = substr( "0$dd", -2 ); $mm = substr( "0$mm", -2 ); $date = "$yy$mm$dd"; } $date; } =item $form->add_date($myconfig, $date, $repeat, $unit); Returns the date $repeat $units from $date in the input format. $date can either be in $myconfig->{dateformat} or 'yyyymmdd' (four digit year required for this option). The valid values for $unit are 'days', 'weeks', 'months', and 'years'. This function is unreliable for $unit values other than 'days' or 'weeks' and can die horribly. =cut sub add_date { my ( $self, $myconfig, $date, $repeat, $unit ) = @_; my $diff = 0; my $spc = $myconfig->{dateformat}; my $yy; my $mm; my $dd; $spc =~ s/\w//g; $spc = substr( $spc, 0, 1 ); if ($date) { if ( $date =~ /\D/ ) { if ( $myconfig->{dateformat} =~ /^yy/ ) { ( $yy, $mm, $dd ) = split /\D/, $date; } elsif ( $myconfig->{dateformat} =~ /^mm/ ) { ( $mm, $dd, $yy ) = split /\D/, $date; } elsif ( $myconfig->{dateformat} =~ /^dd/ ) { ( $dd, $mm, $yy ) = split /\D/, $date; } } else { # ISO ( $yy, $mm, $dd ) = ($date =~ /(....)(..)(..)/); } if ( $unit eq 'days' ) { $diff = $repeat * 86400; } elsif ( $unit eq 'weeks' ) { $diff = $repeat * 604800; } elsif ( $unit eq 'months' ) { $diff = $mm + $repeat; my $whole = int( $diff / 12 ); $yy += $whole; $mm = ( $diff % 12 ); $mm = '12' if $mm == 0; $yy-- if $mm == 12; $diff = 0; } elsif ( $unit eq 'years' ) { $yy += $repeat; } $mm--; my @t = localtime( Time::Local::timelocal( 0, 0, 0, $dd, $mm, $yy ) + $diff ); $t[4]++; $mm = substr( "0$t[4]", -2 ); $dd = substr( "0$t[3]", -2 ); $yy = $t[5] + 1900; if ( $date =~ /\D/ ) { if ( $myconfig->{dateformat} =~ /^yy/ ) { $date = "$yy$spc$mm$spc$dd"; } elsif ( $myconfig->{dateformat} =~ /^mm/ ) { $date = "$mm$spc$dd$spc$yy"; } elsif ( $myconfig->{dateformat} =~ /^dd/ ) { $date = "$dd$spc$mm$spc$yy"; } } else { $date = "$yy$mm$dd"; } } $date; } =item $form->print_button($button, $name); Outputs a submit button to STDOUT. $button is a hashref that contains data about buttons, $name is the key for the element in $button to output. Each value in $button is a reference to a hash of two elements, 'key' and 'value'. $name is the value of the button that gets sent to the server when clicked, $button->{$name}{key} is the accesskey, and $button->{$name}{value} is the label for the button. =cut sub print_button { my ( $self, $button, $name ) = @_; print qq|\n|; } # Database routines used throughout =item $form->db_init($myconfig); Connect to the database that $myconfig is set to use and initialise the base parameters. The connection handle becomes $form->{dbh} and $form->{custom_db_fields} is populated. The connection initiated has autocommit disabled. =cut sub db_init { my ( $self, $myconfig ) = @_; # Handling of HTTP Basic Auth headers my $auth = $ENV{'HTTP_AUTHORIZATION'}; $auth =~ s/Basic //i; # strip out basic authentication preface $auth = MIME::Base64::decode($auth); my ($login, $password) = split(/:/, $auth); $self->{login} = $login; if (!$self->{company}){ $self->{company} = $LedgerSMB::Sysconfig::default_db; } my $dbname = $self->{company}; my $dbconfig = { dbconnect => "dbi:Pg:dbname=$dbname", dbuser => $login, dbpasswd => $password }; $self->{dbh} = $self->dbconnect_noauto($dbconfig) || $self->dberror(); my $dbh = $self->{dbh}; my %date_query = ( 'mm/dd/yy' => 'set DateStyle to \'SQL, US\'', 'mm-dd-yy' => 'set DateStyle to \'POSTGRES, US\'', 'dd/mm/yy' => 'set DateStyle to \'SQL, EUROPEAN\'', 'dd-mm-yy' => 'set DateStyle to \'POSTGRES, EUROPEAN\'', 'dd.mm.yy' => 'set DateStyle to \'GERMAN\'' ); $self->{dbh}->do( $date_query{ $myconfig->{dateformat} } ); $self->{db_dateformat} = $myconfig->{dateformat}; #shim # This is the general version check my $sth = $dbh->prepare(" SELECT value FROM defaults WHERE setting_key = 'version'"); $sth->execute; my ($dbversion) = $sth->fetchrow_array; if ($dbversion ne $self->{dbversion}){ $self->error("Database is not the expected version."); } my $query = "SELECT t.extends, coalesce (t.table_name, 'custom_' || extends) || ':' || f.field_name as field_def FROM custom_table_catalog t JOIN custom_field_catalog f USING (table_id)"; my $sth = $self->{dbh}->prepare($query); $sth->execute; my $ref; while ( $ref = $sth->fetchrow_hashref('NAME_lc') ) { push @{ $self->{custom_db_fields}{ $ref->{extends} } }, $ref->{field_def}; } } =item $form->run_custom_queries($tablename, $query_type[, $linenum]); Runs queries against custom fields for the specified $query_type against $tablename. Valid values for $query_type are any casing of 'SELECT', 'INSERT', and 'UPDATE'. =cut sub run_custom_queries { my ( $self, $tablename, $query_type, $linenum ) = @_; my $dbh = $self->{dbh}; if ( $query_type !~ /^(select|insert|update)$/i ) { $self->error( "Passed incorrect query type to run_custom_queries." ); } my @rc; my %temphash; my @templist; my @elements; my $query; my $did_insert; my $ins_values; my $sth; if ($linenum) { $linenum = "_$linenum"; } $query_type = uc($query_type); for ( @{ $self->{custom_db_fields}{$tablename} } ) { @elements = split( /:/, $_ ); push @{ $temphash{ $elements[0] } }, $elements[1]; } for ( keys %temphash ) { my @data; my $ins_values; $query = "$query_type "; if ( $query_type eq 'UPDATE' ) { $query = "DELETE FROM $_ WHERE row_id = ?"; my $sth = $dbh->prepare($query); $sth->execute( $self->{ "id" . "$linenum" } ) || $self->dberror($query); } elsif ( $query_type eq 'INSERT' ) { $query .= " INTO $_ ("; } my $first = 1; for ( @{ $temphash{$_} } ) { $query .= "$_"; if ( $query_type eq 'UPDATE' ) { $query .= '= ?'; } $ins_values .= "?, "; $query .= ", "; $first = 0; if ( $query_type eq 'UPDATE' or $query_type eq 'INSERT' ) { push @data, $self->{"$_$linenum"}; } } if ( $query_type ne 'INSERT' ) { $query =~ s/, $//; } if ( $query_type eq 'SELECT' ) { $query .= " FROM $_"; } if ( $query_type eq 'SELECT' or $query_type eq 'UPDATE' ) { $query .= " WHERE row_id = ?"; } if ( $query_type eq 'INSERT' ) { $query .= " row_id) VALUES ($ins_values ?)"; } if ( $query_type eq 'SELECT' ) { push @rc, [$query]; } else { unshift( @data, $query ); push @rc, [@data]; } } if ( $query_type eq 'INSERT' ) { for (@rc) { $query = shift( @{$_} ); $sth = $dbh->prepare($query) || $self->db_error($query); $sth->execute( @{$_}, $self->{id} ) || $self->dberror($query); $sth->finish; $did_insert = 1; } } elsif ( $query_type eq 'UPDATE' ) { @rc = $self->run_custom_queries( $tablename, 'INSERT', $linenum ); } elsif ( $query_type eq 'SELECT' ) { for (@rc) { my $query = shift @{$_}; my $sth = $self->{dbh}->prepare($query); $sth->execute( $self->{id} ); my $ref = $sth->fetchrow_hashref('NAME_lc'); for ( keys %{$ref} ) { $self->{$_} = $ref->{$_}; } } } @rc; } =item $form->dbconnect($myconfig); Returns an autocommit connection to the database specified in $myconfig. =cut sub dbconnect { my ( $self, $myconfig ) = @_; # connect to database my $dbh = DBI->connect( $myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd} ) or $self->dberror; $dbh->{pg_enable_utf8} = 1; # set db options if ( $myconfig->{dboptions} ) { $dbh->do( $myconfig->{dboptions} ) || $self->dberror( $myconfig->{dboptions} ); } $dbh; } =item $form->dbconnect_noauto($myconfig); Returns a non-autocommit connection to the database specified in $myconfig. =cut sub dbconnect_noauto { my ( $self, $myconfig ) = @_; # connect to database my $dbh = DBI->connect( $myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, { AutoCommit => 0 } ) or $self->dberror; $dbh->{pg_enable_utf8} = 1; # set db options if ( $myconfig->{dboptions} ) { $dbh->do( $myconfig->{dboptions} ); } $dbh; } =item $form->dbquote($var); If $var is an empty string, return NULL, otherwise return $var as quoted by $form->{dbh}->quote($var). =cut sub dbquote { my ( $self, $var ) = @_; if ( $var eq '' ) { $_ = "NULL"; } else { $_ = $self->{dbh}->quote($var); } $_; } =item $form->update_balance($dbh, $table, $field, $where, $value); B: This is a dangerous private function. All apps calling it must be careful to avoid SQL injection issues. If $value is set, sets the value of $field in $table to the sum of the current stored value and $value. In order to not annihilate the values in $table, $where must contain a WHERE clause that limits the UPDATE to a single row. =cut sub update_balance { # This is a dangerous private function. All apps calling it must # be careful to avoid SQL injection issues my ( $self, $dbh, $table, $field, $where, $value ) = @_; $table = $dbh->quote_identifier($table); $field = $dbh->quote_identifier($field); # if we have a value, go do it if ($value) { # retrieve balance from table my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE"; my ($balance) = $dbh->selectrow_array($query); $balance = $dbh->quote($balance + $value); # update balance $query = "UPDATE $table SET $field = $balance WHERE $where"; $dbh->do($query) || $self->dberror($query); } } =item $form->update_exchangerate($dbh, $curr, $transdate, $buy, $sell); Updates the exchange rates $buy and $sell for the given $currency on $transdate. If there is not yet an exchange rate for $currency on $transdate, an entry is inserted. This returns without doing anything if $curr eq ''. $dbh is not used, favouring $self->{dbh}. =cut sub update_exchangerate { my ( $self, $dbh, $curr, $transdate, $buy, $sell ) = @_; # some sanity check for currency return if ( $curr eq "" ); my $query = qq| SELECT curr FROM exchangerate WHERE curr = ? AND transdate = ? FOR UPDATE|; my $sth = $self->{dbh}->prepare($query); $sth->execute( $curr, $transdate ) || $self->dberror($query); my $set; my @queryargs; if ( $buy && $sell ) { $set = "buy = ?, sell = ?"; @queryargs = ( $buy, $sell ); } elsif ($buy) { $set = "buy = ?"; @queryargs = ($buy); } elsif ($sell) { $set = "sell = ?"; @queryargs = ($sell); } if ( !$set ) { $self->error("Exchange rate missing!"); } if ( $sth->fetchrow_array ) { $query = qq|UPDATE exchangerate SET $set WHERE curr = ? AND transdate = ?|; push( @queryargs, $curr, $transdate ); } else { $query = qq| INSERT INTO exchangerate ( curr, buy, sell, transdate) VALUES (?, ?, ?, ?)|; @queryargs = ( $curr, $buy, $sell, $transdate ); } $sth->finish; $sth = $self->{dbh}->prepare($query); $sth->execute(@queryargs) || $self->dberror($query); } =item $form->save_exchangerate($myconfig, $currency, $transdate, $rate, $fld); Saves the exchange rate $rate for the given $currency on $transdate for the provided purpose in $fld. $fld can be either 'buy' or 'sell'. $myconfig is not used. $self->update_exchangerate is used for the majority of the work. =cut sub save_exchangerate { my ( $self, $myconfig, $currency, $transdate, $rate, $fld ) = @_; my ( $buy, $sell ) = ( 0, 0 ); $buy = $rate if $fld eq 'buy'; $sell = $rate if $fld eq 'sell'; $self->update_exchangerate( $self->{dbh}, $currency, $transdate, $buy, $sell ); } =item $form->get_exchangerate($dbh, $curr, $transdate, $fld); Returns the exchange rate in relation to the default currency for $currency on $transdate for the purpose indicated by $fld. $fld can be either 'buy' or 'sell' to get usable results. $dbh is not used, favouring $self->{dbh}. =cut sub get_exchangerate { my ( $self, $dbh, $curr, $transdate, $fld ) = @_; my $exchangerate = 1; if ($transdate) { my $query = qq| SELECT $fld FROM exchangerate WHERE curr = ? AND transdate = ?|; my $sth = $self->{dbh}->prepare($query); $sth->execute( $curr, $transdate ); ($exchangerate) = $sth->fetchrow_array; $exchangerate = Math::BigFloat->new($exchangerate); $sth->finish; } $exchangerate; } =item $form->check_exchangerate($myconfig, $currency, $transdate, $fld); Returns some true value when an entry for $currency on $transdate is true for the purpose indicated by $fld. $fld can be either 'buy' or 'sell' to get usable results. Returns false if $transdate is not set. $myconfig is not used. =cut sub check_exchangerate { my ( $self, $myconfig, $currency, $transdate, $fld ) = @_; return "" unless $transdate; my $query = qq| SELECT $fld FROM exchangerate WHERE curr = ? AND transdate = ?|; my $sth = $self->{dbh}->prepare($query); $sth->execute( $currency, $transdate ); my ($exchangerate) = $sth->fetchrow_array; $sth->finish; $exchangerate; } =item $form->add_shipto($dbh, $id); Inserts a new address into the table shipto if the value of any of the shipto address components in $form differs to the regular attribute in $form. The inserted value of trans_id is $id, the other fields correspond with the shipto address components of $form. $dbh is unused. =cut sub add_shipto { my ( $self, $dbh, $id ) = @_; my $shipto; foreach my $item ( qw(name address1 address2 city state zipcode country contact phone fax email) ) { if ( $self->{"shipto$item"} ne "" ) { $shipto = 1 if ( $self->{$item} ne $self->{"shipto$item"} ); } } if ($shipto) { my $query = qq| INSERT INTO shipto (trans_id, shiptoname, shiptoaddress1, shiptoaddress2, shiptocity, shiptostate, shiptozipcode, shiptocountry, shiptocontact, shiptophone, shiptofax, shiptoemail) VALUES ( ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?) |; my $sth = $self->{dbh}->prepare($query) || $self->dberror($query); $sth->execute( $id, $self->{shiptoname}, $self->{shiptoaddress1}, $self->{shiptoaddress2}, $self->{shiptocity}, $self->{shiptostate}, $self->{shiptozipcode}, $self->{shiptocountry}, $self->{shiptocontact}, $self->{shiptophone}, $self->{shiptofax}, $self->{shiptoemail} ) || $self->dberror($query); $sth->finish; } } =item $form->get_employee($dbh); Returns a list containing the name and id of the employee $form->{login}. Any portion of $form->{login} including and past '@' are ignored. $dbh is unused. =cut sub get_employee { my ( $self, $dbh ) = @_; my $login = $self->{login}; $login =~ s/@.*//; my $query = qq| SELECT name, id FROM entity WHERE id IN (select entity_id FROM employee WHERE login = ?)|; my $sth = $self->{dbh}->prepare($query); $sth->execute($login); my (@a) = $sth->fetchrow_array(); $a[1] *= 1; $sth->finish; @a; } =item $form->get_name($myconfig, $table[, $transdate]) Sets $form->{name_list} to refer to a list of customers or vendors whose names or numbers match the value found in $form->{$table} and returns the number of matches. $table can be 'vendor', 'customer', or 'employee'; if the optional field $transdate is provided, the result set is further limited to $table entries which were active on the provided date as determined by the start and end dates. The elements of $form->{name_list} are references returned rows in hashref form and are sorted by the name field. The fields of the hash are those of the view $table and the table entity. $myconfig is unused. =cut # this sub gets the id and name from $table sub get_name { my ( $self, $myconfig, $table, $transdate ) = @_; my @queryargs; my $where; if ($transdate) { $where = qq| AND (startdate IS NULL OR startdate <= ?) AND (enddate IS NULL OR enddate >= ?)|; @queryargs = ( $transdate, $transdate ); } # SC: Check for valid table/view name. Other values will cause SQL errors. if ($table !~ /^(vendor|customer|employee)$/i) { $self->error('Invalid name source'); } # Company name is stored in $self->{vendor} or $self->{customer} my $name = $self->like( lc $self->{$table} ); # Vendor and Customer are now views into entity_credit_account. my $query = qq| SELECT * FROM $table t JOIN entity e ON t.entity_id = e.id WHERE (lower(e.name) LIKE ? OR t.${table}number LIKE ?) $where ORDER BY e.name|; unshift( @queryargs, $name, $name, $table ); my $sth = $self->{dbh}->prepare($query); $sth->execute(@queryargs) || $self->dberror($query); my $i = 0; @{ $self->{name_list} } = (); while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) { push( @{ $self->{name_list} }, $ref ); $i++; } $sth->finish; return $i; } =item $form->all_vc($myconfig, $vc, $module, $dbh, $transdate, $job); Populates the list referred to by $form->{all_${vc}} with hashes of either vendor or customer id and name, ordered by the name. This will be vendor details unless $vc is set to 'customer'. This list can be limited to only vendors or customers which are usable on a given day by specifying $transdate. As a further restriction, $form->{all_${vc}} will not be populated if the number of vendors or customers that would be present in that list exceeds, or is equal to, $myconfig->{vclimit}. In addition to the possible population of $form->{all_${vc}}, $form->{employee_id} is looked up if not already set, the list $form->{all_language} is populated using the language table and is sorted by the description, and $form->all_employees, $form->all_departments, $form->all_projects, and $form->all_taxaccounts are all run. $module and $dbh are unused. =cut sub all_vc { my ( $self, $myconfig, $vc, $module, $dbh, $transdate, $job ) = @_; my $ref; $dbh = $self->{dbh}; my $sth; if ($vc eq 'customer'){ $self->{vc_class} = 2; } else { $self->{vc_class} = 1; $vc = 'vendor'; } my $query = qq|SELECT count(*) FROM entity_credit_account where entity_class = ?|; my $where; my @queryargs2 = ($self->{vc_class}); my @queryargs; if ($transdate) { $query .= qq| AND (startdate IS NULL OR startdate <= ?) AND (enddate IS NULL OR enddate >= ?)|; $where = qq| (startdate IS NULL OR startdate <= ?) AND (enddate IS NULL OR enddate >= ?) AND entity_class = ?|; push (@queryargs, $transdate, $transdate, $self->{vc_class}); push (@queryargs2, $transdate, $transdate); } else { $where = " true"; } $sth = $dbh->prepare($query); $sth->execute(@queryargs2); my ($count) = $sth->fetchrow_array; $sth->finish; # build selection list if ( $count < $myconfig->{vclimit} ) { $self->{"${vc}_id"} *= 1; $query = qq|SELECT id, name FROM entity WHERE id IN (select entity_id FROM entity_credit_account WHERE $where) UNION SELECT id,name FROM entity WHERE id = ? ORDER BY name|; push( @queryargs, $self->{"${vc}_id"} ); $sth = $dbh->prepare($query); $sth->execute(@queryargs) || $self->dberror($query); @{ $self->{"all_$vc"} } = (); while ( $ref = $sth->fetchrow_hashref('NAME_lc') ) { push @{ $self->{"all_$vc"} }, $ref; } $sth->finish; } # get self if ( !$self->{employee_id} ) { ( $self->{employee}, $self->{employee_id} ) = split /--/, $self->{employee}; ( $self->{employee}, $self->{employee_id} ) = $self->get_employee($dbh) unless $self->{employee_id}; } $self->all_employees( $myconfig, $dbh, $transdate, 1 ); $self->all_departments( $myconfig, $dbh, $vc ); $self->all_projects( $myconfig, $dbh, $transdate, $job ); # get language codes $query = qq|SELECT * FROM language ORDER BY 2|; $sth = $dbh->prepare($query); $sth->execute || $self->dberror($query); $self->{all_language} = (); while ( $ref = $sth->fetchrow_hashref('NAME_lc') ) { push @{ $self->{all_language} }, $ref; } $sth->finish; $self->all_taxaccounts( $myconfig, $dbh, $transdate ); } =item $form->all_taxaccounts($myconfig, $dbh2[, $transdate]); Get the tax rates and numbers for all the taxes in $form->{taxaccounts}. Does nothing if $form->{taxaccounts} is false. Taxes are listed as a space seperated list of account numbers from the chart. The retrieved values are placed within $form->{${accno}_rate} and $form->{${accno}_taxnumber}. If $transdate is set, then only process taxes that were valid on $transdate. $myconfig and $dbh2 are unused. =cut sub all_taxaccounts { my ( $self, $myconfig, $dbh2, $transdate ) = @_; my $dbh = $self->{dbh}; my $sth; my $query; my $where; my @queryargs = (); if ($transdate) { $where = qq| AND (t.validto >= ? OR t.validto IS NULL)|; push( @queryargs, $transdate ); } if ( $self->{taxaccounts} ) { # rebuild tax rates $query = qq|SELECT t.rate, t.taxnumber FROM tax t JOIN chart c ON (c.id = t.chart_id) WHERE c.accno = ? $where ORDER BY accno, validto|; $sth = $dbh->prepare($query) || $self->dberror($query); foreach my $accno ( split / /, $self->{taxaccounts} ) { $sth->execute( $accno, @queryargs ); ( $self->{"${accno}_rate"}, $self->{"${accno}_taxnumber"} ) = $sth->fetchrow_array; $sth->finish; } } } =item $form->all_employees($myconfig, $dbh2, $transdate, $sales); Sets $form->{all_employee} to be a reference to an array referencing hashes of employee information. The hashes are of the form {'id' => id, 'name' => name}. If $transdate is set, the query is limited to employees who are active on that day. If $sales is true, only employees with the sales flag set are added. $dbh2 is unused. =cut sub all_employees { my ( $self, $myconfig, $dbh2, $transdate, $sales ) = @_; my $dbh = $self->{dbh}; my @whereargs = (); # setup employees/sales contacts my $query = qq| SELECT id, name FROM entity WHERE id IN (SELECT entity_id FROM employee WHERE|; if ($transdate) { $query .= qq| (startdate IS NULL OR startdate <= ?) AND (enddate IS NULL OR enddate >= ?) AND|; @whereargs = ( $transdate, $transdate ); } else { $query .= qq| enddate IS NULL AND|; } if ($sales) { $query .= qq| sales = '1' AND|; } $query =~ s/(WHERE|AND)$//; $query .= qq|) ORDER BY name|; my $sth = $dbh->prepare($query); $sth->execute(@whereargs) || $self->dberror($query); while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) { push @{ $self->{all_employee} }, $ref; } $sth->finish; } =item $form->all_projects($myconfig, $dbh2[, $transdate, $job]); Populates the list referred to as $form->{all_project} with hashes detailing all projects. If $job is true, limit the projects to those whose ids are not also present in parts with a project_id > 0. If $transdate is set, the projects are limited to those valid on $transdate. If $form->{language_code} is set, include the translation description in the project list and limit to translations with a matching language_code. The result list, $form->{all_project}, is sorted by projectnumber. $myconfig and $dbh2 are unused. $job appears to be part of attempted job- costing support. =cut sub all_projects { my ( $self, $myconfig, $dbh2, $transdate, $job ) = @_; my $dbh = $self->{dbh}; my @queryargs = (); my $where = "1 = 1"; $where = qq|id NOT IN (SELECT id FROM parts WHERE project_id > 0)| if !$job; my $query = qq|SELECT * FROM project WHERE $where|; if ( $self->{language_code} ) { $query = qq| SELECT pr.*, t.description AS translation FROM project pr LEFT JOIN translation t ON (t.trans_id = pr.id) WHERE t.language_code = ?|; push( @queryargs, $self->{language_code} ); } if ($transdate) { $query .= qq| AND (startdate IS NULL OR startdate <= ?) AND (enddate IS NULL OR enddate >= ?)|; push( @queryargs, $transdate, $transdate ); } $query .= qq| ORDER BY projectnumber|; my $sth = $dbh->prepare($query); $sth->execute(@queryargs) || $self->dberror($query); @{ $self->{all_project} } = (); while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) { push @{ $self->{all_project} }, $ref; } $sth->finish; } =item $form->all_departments($myconfig, $dbh2, $vc); Set $form->{all_department} to be a reference to a list of hashrefs describing departments of the form {'id' => id, 'description' => description}. If $vc is 'customer', further limit the results to those whose role is 'P' (Profit Center). This procedure is internally followed by a call to $form->all_years($myconfig). $dbh2 is not used. =cut sub all_departments { my ( $self, $myconfig, $dbh2, $vc ) = @_; my $dbh = $self->{dbh}; my $where = "1 = 1"; if ($vc) { if ( $vc eq 'customer' ) { $where = " role = 'P'"; } } my $query = qq|SELECT id, description FROM department WHERE $where ORDER BY 2|; my $sth = $dbh->prepare($query); $sth->execute || $self->dberror($query); @{ $self->{all_department} } = (); while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) { push @{ $self->{all_department} }, $ref; } $sth->finish; $self->all_years($myconfig); } =item $form->all_years($myconfig[, $dbh2]); Populates the hash $form->{all_month} with a mapping between a two-digit month number and the English month name. Populates the list $form->{all_years} with the years between the year of the oldest transaction date in acc_trans and the newest, inclusive. $dbh2 is unused. =cut sub all_years { my ( $self, $myconfig, $dbh2 ) = @_; my $dbh = $self->{dbh}; # get years my $query = qq| SELECT (SELECT transdate FROM acc_trans ORDER BY transdate asc LIMIT 1), (SELECT transdate FROM acc_trans ORDER BY transdate desc LIMIT 1)|; my ( $startdate, $enddate ) = $dbh->selectrow_array($query); if ( $myconfig->{dateformat} =~ /^yy/ ) { ($startdate) = split /\W/, $startdate; ($enddate) = split /\W/, $enddate; } else { (@_) = split /\W/, $startdate; $startdate = $_[2]; (@_) = split /\W/, $enddate; $enddate = $_[2]; } $self->{all_years} = (); $startdate = substr( $startdate, 0, 4 ); $enddate = substr( $enddate, 0, 4 ); while ( $enddate >= $startdate ) { push @{ $self->{all_years} }, $enddate--; } #this should probably be changed to use locale %{ $self->{all_month} } = ( '01' => 'January', '02' => 'February', '03' => 'March', '04' => 'April', '05' => 'May ', '06' => 'June', '07' => 'July', '08' => 'August', '09' => 'September', '10' => 'October', '11' => 'November', '12' => 'December' ); } =item $form->create_links($module, $myconfig, $vc[, $job]); Populates the hash referred to as $form->{${module}_links} details about accounts that have $module in their link field. The hash is keyed upon link elements such as 'AP_amount' and 'AR_tax' and they refer to lists of hashes containing accno and description for the appropriate accounts. If the key does not contain 'tax', the account number is appended to the space seperated list $form->{accounts}. $module is typically 'AR' or 'AP' and is the base type of the accounts looked up. If $form->{id} is not set, check $form->{"$form->{vc}_id"}. If neither is set, use $form->lastname_used to populate the details. If $form->{id} is set, populate the invnumber, transdate, ${vc}_id, datepaid, duedate, ordnumber, taxincluded, currency, notes, intnotes, ${vc}, department_id, department, oldinvtotal, oldtotalpaid, employee_id, employee, language_code, ponumber, reverse, printed, emailed, queued, recurring, exchangerate, and acc_trans attributes of $form with details about the transaction $form->{id}. All of these attributes, save for acc_trans, are scalar; $form->{acc_trans} refers to a hash keyed by link elements whose values are lists of references to hashes describing acc_trans table entries corresponding to the transaction $form->{id}. The elements in the acc_trans entry hashes are accno, description, source, amount, memo, transdate, cleared, project_id, projectnumber, and exchangerate. The closedto, revtrans, and currencies $form attributes are filled with values from the defaults table, while $form->{current_date} is populated with the current date. If $form->{id} is not set, then $form->{transdate} also takes on the current date. After all this, it calls $form->all_vc to conclude. =cut sub create_links { my ( $self, $module, $myconfig, $vc, $job ) = @_; # get last customers or vendors my ( $query, $sth ); if (!$self->{dbh}) { $self->db_init($myconfig); } my $dbh = $self->{dbh}; my %xkeyref = (); my $val; my $ref; my $key; # now get the account numbers $query = qq|SELECT accno, description, link FROM chart WHERE link LIKE ? ORDER BY accno|; $sth = $dbh->prepare($query); $sth->execute( "%" . "$module%" ) || $self->dberror($query); $self->{accounts} = ""; while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) { foreach my $key ( split /:/, $ref->{link} ) { if ( $key =~ /$module/ ) { # cross reference for keys $xkeyref{ $ref->{accno} } = $key; push @{ $self->{"${module}_links"}{$key} }, { accno => $ref->{accno}, description => $ref->{description} }; $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/; } } } $sth->finish; my $arap = ( $vc eq 'customer' ) ? 'ar' : 'ap'; $vc = 'vendor' unless $vc eq 'customer'; if ( $self->{id} ) { $query = qq| SELECT a.invnumber, a.transdate, a.entity_id, a.datepaid, a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes, a.intnotes, ce.name AS $vc, a.department_id, d.description AS department, a.amount AS oldinvtotal, a.paid AS oldtotalpaid, a.person_id, e.name AS employee, c.language_code, a.ponumber, a.reverse FROM $arap a JOIN entity_credit_account c USING (entity_id) JOIN entity ce ON (ce.id = c.entity_id) LEFT JOIN employee er ON (er.entity_id = a.person_id) LEFT JOIN entity e ON (er.entity_id = e.id) LEFT JOIN department d ON (d.id = a.department_id) WHERE a.id = ? AND c.entity_class = (select id FROM entity_class WHERE class ilike ?)|; $sth = $dbh->prepare($query); $sth->execute( $self->{id}, $self->{vc} ) || $self->dberror($query); $ref = $sth->fetchrow_hashref('NAME_lc'); $self->db_parse_numeric(sth=>$sth, hashref=>$ref); foreach $key ( keys %$ref ) { $self->{$key} = $ref->{$key}; } $sth->finish; # get printed, emailed $query = qq| SELECT s.printed, s.emailed, s.spoolfile, s.formname FROM status s WHERE s.trans_id = ?|; $sth = $dbh->prepare($query); $sth->execute( $self->{id} ) || $self->dberror($query); while ( $ref = $sth->fetchrow_hashref('NAME_lc') ) { $self->{printed} .= "$ref->{formname} " if $ref->{printed}; $self->{emailed} .= "$ref->{formname} " if $ref->{emailed}; $self->{queued} .= "$ref->{formname} " . "$ref->{spoolfile} " if $ref->{spoolfile}; } $sth->finish; for (qw(printed emailed queued)) { $self->{$_} =~ s/ +$//g } # get recurring $self->get_recurring($dbh); # get amounts from individual entries $query = qq| SELECT c.accno, c.description, a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, p.projectnumber FROM acc_trans a JOIN chart c ON (c.id = a.chart_id) LEFT JOIN project p ON (p.id = a.project_id) WHERE a.trans_id = ? AND a.fx_transaction = '0' ORDER BY transdate|; $sth = $dbh->prepare($query); $sth->execute( $self->{id} ) || $self->dberror($query); my $fld = ( $vc eq 'customer' ) ? 'buy' : 'sell'; $self->{exchangerate} = $self->get_exchangerate( $dbh, $self->{currency}, $self->{transdate}, $fld ); # store amounts in {acc_trans}{$key} for multiple accounts while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) { $ref->{exchangerate} = $self->get_exchangerate( $dbh, $self->{currency}, $ref->{transdate}, $fld ); if ($self->{reverse}){ $ref->{amount} *= -1; } push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref; } $sth->finish; } else { if ( !$self->{"$self->{vc}_id"} ) { $self->lastname_used( $myconfig, $dbh, $vc, $module ); } } for (qw(current_date curr closedto revtrans)) { if ($_ eq 'closedto'){ $query = qq| SELECT value::date FROM defaults WHERE setting_key = '$_'|; } elsif ($_ eq 'current_date') { $query = qq| select $_|; } else { $query = qq| SELECT value FROM defaults WHERE setting_key = '$_'|; } $sth = $dbh->prepare($query); $sth->execute || $self->dberror($query); ($val) = $sth->fetchrow_array(); if ( $_ eq 'curr' ) { $self->{currencies} = $val; } else { $self->{$_} = $val; } $sth->finish; } if (!$self->{id}){ $self->{transdate} = $self->{current_date}; } $self->all_vc( $myconfig, $vc, $module, $dbh, $self->{transdate}, $job ); } =item $form->lastname_used($myconfig, $dbh2, $vc, $module); Fills the name, currency, ${vc}_id, duedate, and possibly invoice_notes attributes of $form with the last used values for the transaction type specified by both $vc and $form->{type}. $vc can be either 'vendor' or 'customer' and if unspecified will take on the value given in $form->{vc}, defaulting to 'vendor'. If $form->{type} matches /_order/, the transaction type used is order, if it matches /_quotation/, quotations are looked through. If $form->{type} does not match either of the above, then ar or ap transactions are used. $myconfig, $dbh2, and $module are unused. =cut sub lastname_used { my ( $self, $myconfig, $dbh2, $vc, $module ) = @_; my $dbh = $self->{dbh}; $vc ||= $self->{vc}; # add default to correct for improper passing my $arap; my $where; if ($vc eq 'customer') { $arap = 'ar'; } else { $arap = 'ap'; $vc = 'vendor'; } my $sth; if ( $self->{type} =~ /_order/ ) { $arap = 'oe'; $where = "quotation = '0'"; } if ( $self->{type} =~ /_quotation/ ) { $arap = 'oe'; $where = "quotation = '1'"; } $where = "AND $where " if $where; my $inv_notes; $inv_notes = "ct.invoice_notes," if $vc eq 'customer'; my $query = qq| SELECT entity.name, ct.curr AS currency, entity_id AS ${vc}_id, current_date + ct.terms AS duedate, $inv_notes ct.curr AS currency FROM $vc ct JOIN entity ON (ct.entity_id = entity.id) WHERE entity.id = (select entity_id from $arap where entity_id IS NOT NULL $where order by id DESC limit 1)|; $sth = $self->{dbh}->prepare($query); $sth->execute() || $self->dberror($query); my $ref = $sth->fetchrow_hashref('NAME_lc'); for ( keys %$ref ) { $self->{$_} = $ref->{$_} } $sth->finish; } =item $form->current_date($myconfig[, $thisdate, $days]); If $thisdate is false, get the current date from the database. If $thisdate is true, get the date $days days from $thisdate in the date format specified by $myconfig->{dateformat} from the database. =cut sub current_date { my ( $self, $myconfig, $thisdate, $days ) = @_; my $dbh = $self->{dbh}; my $query; my @queryargs; $days *= 1; if ($thisdate) { my $dateformat = $myconfig->{dateformat}; if ( $myconfig->{dateformat} !~ /^y/ ) { my @a = split /\D/, $thisdate; $dateformat .= "yy" if ( length $a[2] > 2 ); } if ( $thisdate !~ /\D/ ) { $dateformat = 'yyyymmdd'; } $query = qq|SELECT (to_date(?, ?) + ?::interval)::date AS thisdate|; @queryargs = ( $thisdate, $dateformat, sprintf('%d days', $days) ); } else { $query = qq|SELECT current_date AS thisdate|; @queryargs = (); } my $sth = $dbh->prepare($query); $sth->execute(@queryargs); my ($thisdate) = $sth->fetchrow_array; $thisdate; } =item $form->like($str); Returns '%$str%' =cut sub like { my ( $self, $str ) = @_; "%$str%"; } =item $form->redo_rows($flds, $new, $count, $numrows); $flds refers to a list of field names and $new refers to a list of row detail hashes with the elements of $flds as keys as well as runningnumber for an order or another multi-row item that normally expresses elements in the form $form->{${fieldname}_${index}}. For every $field in @{$flds} populates $form->{${field}_$i} with an appropriate value from a $new detail hash where $i is an index between 1 and $count. The ordering of the details is done in terms of the runningnumber element of the row detail hashes in $new. All $form attributes with names of the form ${field}_$i where the index $i is between $count + 1 and $numrows is deleted. =cut sub redo_rows { my ( $self, $flds, $new, $count, $numrows ) = @_; my @ndx = (); for ( 1 .. $count ) { push @ndx, { num => $new->[ $_ - 1 ]->{runningnumber}, ndx => $_ }; } my $i = 0; # fill rows foreach my $item ( sort { $a->{num} <=> $b->{num} } @ndx ) { $i++; my $j = $item->{ndx} - 1; for ( @{$flds} ) { $self->{"${_}_$i"} = $new->[$j]->{$_} } } # delete empty rows for $i ( $count + 1 .. $numrows ) { for ( @{$flds} ) { delete $self->{"${_}_$i"} } } } =item $form->get_partsgroup($myconfig[, $p]); Populates the list referred to as $form->{all_partsgroup}. $p refers to a hash that describes which partsgroups to retrieve. $p->{searchitems} can be 'part', 'service', 'assembly', 'labor', or 'nolabor' and will limit the groups to those that contain the item type described. $p->{searchitems} and $p->{all} conflict. If $p->{all} is set and $p->{language_code} is not, all partsgroups are retrieved. If $p->{language_code} is set, also include the translation description specified by $p->{language_code} for the partsgroup. The results in $form->{all_partsgroup} are normally sorted by partsgroup name. If a language_code is specified, the results are then sorted by the translated description. $myconfig is unused. =cut sub get_partsgroup { my ( $self, $myconfig, $p ) = @_; my $dbh = $self->{dbh}; my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup FROM partsgroup pg JOIN parts p ON (p.partsgroup_id = pg.id)|; my $where; my $sortorder = "partsgroup"; if ( $p->{searchitems} eq 'part' ) { $where = qq| WHERE (p.inventory_accno_id > 0 AND p.income_accno_id > 0)|; } elsif ( $p->{searchitems} eq 'service' ) { $where = qq| WHERE p.inventory_accno_id IS NULL|; } elsif ( $p->{searchitems} eq 'assembly' ) { $where = qq| WHERE p.assembly = '1'|; } elsif ( $p->{searchitems} eq 'labor' ) { $where = qq| WHERE p.inventory_accno_id > 0 AND p.income_accno_id IS NULL|; } elsif ( $p->{searchitems} eq 'nolabor' ) { $where = qq| WHERE p.income_accno_id > 0|; } if ( $p->{all} ) { $query = qq|SELECT id, partsgroup FROM partsgroup|; } my @queryargs = (); if ( $p->{language_code} ) { $sortorder = "translation"; $query = qq| SELECT DISTINCT pg.id, pg.partsgroup, t.description AS translation FROM partsgroup pg JOIN parts p ON (p.partsgroup_id = pg.id) LEFT JOIN translation t ON (t.trans_id = pg.id AND t.language_code = ?)|; @queryargs = ( $p->{language_code} ); } $query .= qq| $where ORDER BY $sortorder|; my $sth = $dbh->prepare($query); $sth->execute(@queryargs) || $self->dberror($query); $self->{all_partsgroup} = (); while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) { push @{ $self->{all_partsgroup} }, $ref; } $sth->finish; } =item $form->update_status($myconfig); DELETEs all status rows which have a formname of $form->{formname} and a trans_id of $form->{id}. INSERTs a new row into status where trans_id is $form->{id}, formname is $form->{formname}, printed and emailed are true if their respective $form attributes match /$form->{formname}/, and spoolfile is the file extracted from the string $form->{queued} or NULL if there is no entry for $form->{formname}. $myconfig is unused. =cut sub update_status { my ( $self, $myconfig ) = @_; # no id return return unless $self->{id}; my $dbh = $self->{dbh}; my %queued = split / +/, $self->{queued}; my $spoolfile = ( $queued{ $self->{formname} } ) ? "'$queued{$self->{formname}}'" : 'NULL'; my $query = qq|DELETE FROM status WHERE formname = ? AND trans_id = ?|; my $sth = $dbh->prepare($query); $sth->execute( $self->{formname}, $self->{id} ) || $self->dberror($query); $sth->finish; my $printed = ( $self->{printed} =~ /$self->{formname}/ ) ? "1" : "0"; my $emailed = ( $self->{emailed} =~ /$self->{formname}/ ) ? "1" : "0"; $query = qq| INSERT INTO status (trans_id, printed, emailed, spoolfile, formname) VALUES (?, ?, ?, ?, ?)|; $sth = $dbh->prepare($query); $sth->execute( $self->{id}, $printed, $emailed, $spoolfile, $self->{formname} ); $sth->finish; } =item $form->save_status(); Clears out any old status entries for $form->{id} and saves new status entries. Queued form names are extracted from $form->{queued}. Printed and emailed form names are extracted from $form->{printed} and $form->{emailed}. The queued, printed, and emailed fields are space seperated lists. =cut sub save_status { my ($self) = @_; my $dbh = $self->{dbh}; my $formnames = $self->{printed}; my $emailforms = $self->{emailed}; my $query = qq|DELETE FROM status WHERE trans_id = ?|; my $sth = $dbh->prepare($query); $sth->execute( $self->{id} ); $sth->finish; my %queued; my $formname; my $printed; my $emailed; if ( $self->{queued} ) { %queued = split / +/, $self->{queued}; foreach $formname ( keys %queued ) { $printed = ( $self->{printed} =~ /$formname/ ) ? "1" : "0"; $emailed = ( $self->{emailed} =~ /$formname/ ) ? "1" : "0"; if ( $queued{$formname} ) { $query = qq| INSERT INTO status (trans_id, printed, emailed, spoolfile, formname) VALUES (?, ?, ?, ?, ?)|; $sth = $dbh->prepare($query); $sth->execute( $self->{id}, $printed, $emailed, $queued{$formname}, $formname ) || $self->dberror($query); $sth->finish; } $formnames =~ s/$formname//; $emailforms =~ s/$formname//; } } # save printed, emailed info $formnames =~ s/^ +//g; $emailforms =~ s/^ +//g; my %status = (); for ( split / +/, $formnames ) { $status{$_}{printed} = 1 } for ( split / +/, $emailforms ) { $status{$_}{emailed} = 1 } foreach my $formname ( keys %status ) { $printed = ( $formnames =~ /$self->{formname}/ ) ? "1" : "0"; $emailed = ( $emailforms =~ /$self->{formname}/ ) ? "1" : "0"; $query = qq| INSERT INTO status (trans_id, printed, emailed, formname) VALUES (?, ?, ?, ?)|; $sth = $dbh->prepare($query); $sth->execute( $self->{id}, $printed, $emailed, $formname ); $sth->finish; } $dbh->commit; } =item $form->get_recurring(); Sets $form->{recurring} to contain info about the recurrence schedule for the action $form->{id}. $form->{recurring} is of the same form used by $form->save_recurring($dbh2, $myconfig). reference,startdate,repeat,unit,howmany,payment,print,email,message text date int text int int text text text =cut sub get_recurring { my ($self) = @_; my $dbh = $self->{dbh}; my $query = qq/ SELECT s.*, se.formname || ':' || se.format AS emaila, se.message, sp.formname || ':' || sp.format || ':' || sp.printer AS printa FROM recurring s LEFT JOIN recurringemail se ON (s.id = se.id) LEFT JOIN recurringprint sp ON (s.id = sp.id) WHERE s.id = ?/; my $sth = $dbh->prepare($query); $sth->execute( $self->{id} ) || $self->dberror($query); for (qw(email print)) { $self->{"recurring$_"} = "" } while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) { for ( keys %$ref ) { $self->{"recurring$_"} = $ref->{$_} } $self->{recurringemail} .= "$ref->{emaila}:"; $self->{recurringprint} .= "$ref->{printa}:"; for (qw(emaila printa)) { delete $self->{"recurring$_"} } } $sth->finish; chop $self->{recurringemail}; chop $self->{recurringprint}; if ( $self->{recurringstartdate} ) { $self->{recurringreference} = $self->escape( $self->{recurringreference}, 1 ); $self->{recurringmessage} = $self->escape( $self->{recurringmessage}, 1 ); for ( qw(reference startdate repeat unit howmany payment print email message) ) { $self->{recurring} .= qq|$self->{"recurring$_"},|; } chop $self->{recurring}; } } =item $form->save_recurring($dbh2, $myconfig); Saves or deletes recurring transaction scheduling. $form->{id} is used to determine the id used in the various recurring tables. A recurring transaction schedule is deleted by having $form->{recurring} be false. For adding or updating a schedule, $form->{recurring} is a comma seperated field with partial subfield quoting of the form: reference,startdate,repeat,unit,howmany,payment,print,email,message text date int text int int text text text =over =item reference A URI-encoded reference string for the recurrence set. =item startdate The index date for the recurrence. =item repeat The unitless repetition frequency. =item unit The interval unit used. Can be 'days', 'weeks', 'months', or 'years', capitalisation and pluralisation ignored. =item howmany The number of recurrences for the transaction. =item payment Flag to indicate if a payment is included in the transaction. =item print A colon seperated list of formname:format:printer triplets. =item email A colon seperated list of formname:format pairs. =item message A URI-encoded message for the emails to be sent. =back Values for the nextdate and enddate columns of the recurring table are calculated using startdate, repeat, unit, howmany, and the current database date. All other fields of the recurring, recurringemail, and recurringprint are obtained directly from $form->{recurring}. B: This function does not check the validity of most subfields of $form->{recurring}. $dbh2 is not used. =cut sub save_recurring { my ( $self, $dbh2, $myconfig ) = @_; my $dbh = $self->{dbh}; my $query; $query = qq|DELETE FROM recurring WHERE id = ?|; my $sth = $dbh->prepare($query) || $self->dberror($query); $sth->execute( $self->{id} ) || $self->dberror($query); $query = qq|DELETE FROM recurringemail WHERE id = ?|; $sth = $dbh->prepare($query) || $self->dberror($query); $sth->execute( $self->{id} ) || $self->dberror($query); $query = qq|DELETE FROM recurringprint WHERE id = ?|; $sth = $dbh->prepare($query) || $self->dberror($query); $sth->execute( $self->{id} ) || $self->dberror($query); if ( $self->{recurring} ) { my %s = (); ( $s{reference}, $s{startdate}, $s{repeat}, $s{unit}, $s{howmany}, $s{payment}, $s{print}, $s{email}, $s{message} ) = split /,/, $self->{recurring}; if ($s{unit} !~ /^(day|week|month|year)s?$/i){ $dbh->rollback; $self->error("Invalid recurrence unit"); } if ($s{howmany} == 0){ $self->error("Cannot set to recur 0 times"); } for (qw(reference message)) { $s{$_} = $self->unescape( $s{$_} ) } for (qw(repeat howmany payment)) { $s{$_} *= 1 } # calculate enddate my $advance = $s{repeat} * ( $s{howmany} - 1 ); my %interval; $interval{'Pg'} = "(?::date + interval '$advance $s{unit}')"; $query = qq|SELECT $interval{$myconfig->{dbdriver}}|; my ($enddate) = $dbh->selectrow_array($query, undef, $s{startdate}); # calculate nextdate $query = qq| SELECT current_date - ?::date AS a, ?::date - current_date AS b|; $sth = $dbh->prepare($query) || $self->dberror($query); $sth->execute( $s{startdate}, $enddate ); my ( $a, $b ) = $sth->fetchrow_array; if ( $a + $b ) { $advance = int( ( $a / ( $a + $b ) ) * ( $s{howmany} - 1 ) + 1 ) * $s{repeat}; } else { $advance = 0; } my $nextdate = $enddate; if ( $advance > 0 ) { if ( $advance < ( $s{repeat} * $s{howmany} ) ) { $query = qq|SELECT (?::date + interval '$advance $s{unit}')|; ($nextdate) = $dbh->selectrow_array($query, undef, $s{startdate}); } } else { $nextdate = $s{startdate}; } if ( $self->{recurringnextdate} ) { $nextdate = $self->{recurringnextdate}; $query = qq|SELECT ?::date - ?::date|; if ( $dbh->selectrow_array($query, undef, $enddate, $nextdate) < 0 ) { undef $nextdate; } } $self->{recurringpayment} *= 1; $query = qq| INSERT INTO recurring (id, reference, startdate, enddate, nextdate, repeat, unit, howmany, payment) VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)|; $sth = $dbh->prepare($query); $sth->execute( $self->{id}, $s{reference}, $s{startdate}, $enddate, $nextdate, $s{repeat}, $s{unit}, $s{howmany}, $s{payment} ); my @p; my $p; my $i; my $sth; if ( $s{email} ) { # formname:format @p = split /:/, $s{email}; $query = qq|INSERT INTO recurringemail (id, formname, format, message) VALUES (?, ?, ?, ?)|; $sth = $dbh->prepare($query) || $self->dberror($query); for ( $i = 0 ; $i <= $#p ; $i += 2 ) { $sth->execute( $self->{id}, $p[$i], $p[ $i + 1 ], $s{message} ); } $sth->finish; } if ( $s{print} ) { # formname:format:printer @p = split /:/, $s{print}; $query = qq|INSERT INTO recurringprint (id, formname, format, printer) VALUES (?, ?, ?, ?)|; $sth = $dbh->prepare($query) || $self->dberror($query); for ( $i = 0 ; $i <= $#p ; $i += 3 ) { $p = ( $p[ $i + 2 ] ) ? $p[ $i + 2 ] : ""; $sth->execute( $self->{id}, $p[$i], $p[ $i + 1 ], $p ); } $sth->finish; } } $dbh->commit; } =item $form->save_intnotes($myconfig, $vc); Sets the intnotes field of the entry in the table $vc that has the id $form->{id} to the value of $form->{intnotes}. Does nothing if $form->{id} is not set. =cut sub save_intnotes { my ( $self, $myconfig, $vc ) = @_; # no id return return unless $self->{id}; my $dbh = $self->{dbh}; my $query = qq|UPDATE $vc SET intnotes = ? WHERE id = ?|; my $sth = $dbh->prepare($query); $sth->execute( $self->{intnotes}, $self->{id} ) || $self->dberror($query); $dbh->commit; } =item $form->update_defaults($myconfig, $fld[, $dbh]); Updates the defaults entry for the setting $fld following rules specified by the existing value and returns the processed value that results. If $form is false, such as the case when invoked as "Form::update_defaults('',...)", $dbh is used as the handle. When $form is set, it uses $form->{dbh}, initialising the connection if it does not yet exist. The entry $fld must exist prior to executing this function and this update function does not handle the general case of updating the defaults table. B: rules handling is currently broken. Rules followed by this function's processing: =over =item * If digits are found in the field, increment the left-most set. This change, unlike the others is reflected in the UPDATE. =item * Replace with the date specified in $form->{transdate} formatted as $myconfig->{dateformat}. =item * Replace with the value of $form->{currency} =back =cut sub update_defaults { my ( $self, $myconfig, $fld ) = @_; if ( !$self->{dbh} && $self ) { $self->db_init($myconfig); } my $dbh = $self->{dbh}; if ( !$self ) { $dbh = $_[3]; } my $query = qq| SELECT value FROM defaults WHERE setting_key = ? FOR UPDATE|; my $sth = $dbh->prepare($query); $sth->execute($fld); ($_) = $sth->fetchrow_array(); $_ = "0" unless $_; # check for and replace # , , , , or variations of # , , , # , , only for parts # for customer and vendors my $num = $_; ($num) = $num =~ /(\d+)/; if ( defined $num ) { my $incnum; # if we have leading zeros check how long it is if ( $num =~ /^0/ ) { my $l = length $num; $incnum = $num + 1; $l -= length $incnum; # pad it out with zeros my $padzero = "0" x $l; $incnum = ( "0" x $l ) . $incnum; } else { $incnum = $num + 1; } s/$num/$incnum/; } my $dbvar = $_; my $var = $_; my $str; my $param; if (/<\?lsmb /) { while (/<\?lsmb /) { s/<\?lsmb .*? \?>//; last unless $&; $param = $&; $str = ""; if ( $param =~ /<\?lsmb date \?>/i ) { $str = ( $self->split_date( $myconfig->{dateformat}, $self->{transdate} ) )[0]; $var =~ s/$param/$str/; } if ( $param =~ /<\?lsmb (name|business|description|item|partsgroup|phone|custom)/i ) { #SC: XXX hairy, undoc, possibly broken my $fld = lc $&; $fld =~ s/<\?lsmb //; if ( $fld =~ /name/ ) { if ( $self->{type} ) { $fld = $self->{vc}; } } my $p = $param; $p =~ s/(<|>|%)//g; my @p = split / /, $p; my @n = split / /, uc $self->{$fld}; if ( $#p > 0 ) { for ( my $i = 1 ; $i <= $#p ; $i++ ) { $str .= substr( $n[ $i - 1 ], 0, $p[$i] ); } } else { ($str) = split /--/, $self->{$fld}; } $var =~ s/$param/$str/; $var =~ s/\W//g if $fld eq 'phone'; } if ( $param =~ /<\?lsmb (yy|mm|dd)/i ) { # SC: XXX Does this even work anymore? my $p = $param; $p =~ s/(<|>|%)//g; my $spc = $p; $spc =~ s/\w//g; $spc = substr( $spc, 0, 1 ); my %d = ( yy => 1, mm => 2, dd => 3 ); my @p = (); my @a = $self->split_date( $myconfig->{dateformat}, $self->{transdate} ); for ( sort keys %d ) { push @p, $a[ $d{$_} ] if ( $p =~ /$_/ ) } $str = join $spc, @p; $var =~ s/$param/$str/; } if ( $param =~ /<\?lsmb curr/i ) { $var =~ s/$param/$self->{currency}/; } } } my $query = qq| UPDATE defaults SET value = ? WHERE setting_key = ?|; my $sth = $dbh->prepare($query); $sth->execute( $dbvar, $fld ) || $self->dberror($query); $dbh->commit; $var; } =item $form->db_prepare_vars(var1, var2, ..., varI) Undefines $form->{varI}, 1 <= I <= I, iff $form-<{varI is both false and not "0". =cut sub db_prepare_vars { my $self = shift; for (@_) { if ( !$self->{$_} and $self->{$_} ne "0" ) { undef $self->{$_}; } } } =item $form->split_date($dateformat[, $date]); Returns ($rv, $yy, $mm, $dd) for the provided $date, or the current date if no date is provided. $rv is a seperator-free merging of the fields $yy, $mm, and $dd in the ordering supplied by $dateformat. If the supplied $date does not contain non-digit characters, $rv is $date and the other return values are undefined. $yy is two digits. =cut sub split_date { my ( $self, $dateformat, $date ) = @_; my $mm; my $dd; my $yy; my $rv; if ( !$date ) { my @d = localtime; $dd = $d[3]; $mm = ++$d[4]; $yy = substr( $d[5], -2 ); $mm = substr( "0$mm", -2 ); $dd = substr( "0$dd", -2 ); } if ( $dateformat =~ /^yy/ ) { if ($date) { if ( $date =~ /\D/ ) { ( $yy, $mm, $dd ) = split /\D/, $date; $mm *= 1; $dd *= 1; $mm = substr( "0$mm", -2 ); $dd = substr( "0$dd", -2 ); $yy = substr( $yy, -2 ); $rv = "$yy$mm$dd"; } else { $rv = $date; } } else { $rv = "$yy$mm$dd"; } } elsif ( $dateformat =~ /^mm/ ) { if ($date) { if ( $date =~ /\D/ ) { ( $mm, $dd, $yy ) = split /\D/, $date; $mm *= 1; $dd *= 1; $mm = substr( "0$mm", -2 ); $dd = substr( "0$dd", -2 ); $yy = substr( $yy, -2 ); $rv = "$mm$dd$yy"; } else { $rv = $date; } } else { $rv = "$mm$dd$yy"; } } elsif ( $dateformat =~ /^dd/ ) { if ($date) { if ( $date =~ /\D/ ) { ( $dd, $mm, $yy ) = split /\D/, $date; $mm *= 1; $dd *= 1; $mm = substr( "0$mm", -2 ); $dd = substr( "0$dd", -2 ); $yy = substr( $yy, -2 ); $rv = "$dd$mm$yy"; } else { $rv = $date; } } else { $rv = "$dd$mm$yy"; } } ( $rv, $yy, $mm, $dd ); } =item $form->format_date($date); Returns $date converted from 'yyyy-mm-dd' format to the format specified by $form->{db_dateformat}. If the supplied date does not match /^\d{4}\D/, return the supplied date. This function takes a four digit year and returns the date with a four digit year. =cut sub format_date { # takes an iso date in, and converts it to the date for printing my ( $self, $date ) = @_; my $datestring; if ( $date =~ /^\d{4}\D/ ) { # is an ISO date $datestring = $self->{db_dateformat}; my ( $yyyy, $mm, $dd ) = split( /\W/, $date ); $datestring =~ s/y+/$yyyy/; $datestring =~ s/mm/$mm/; $datestring =~ s/dd/$dd/; } else { # return date $datestring = $date; } $datestring; } =item $form->from_to($yyyy, $mm[, $interval]); Returns the date $yyyy-$mm-01 and the the last day of the month interval - 1 months from then in the form ($form->format_date(fromdate), $form->format_date(later)). If $interval is false but defined, the later date is the current date. This function dies horribly when $mm + $interval > 24 =cut sub from_to { my ( $self, $yyyy, $mm, $interval ) = @_; my @t; my $dd = 1; my $fromdate = "$yyyy-${mm}-01"; my $bd = 1; if ( defined $interval ) { if ( $interval == 12 ) { $yyyy++; } else { if ( ( $mm += $interval ) > 12 ) { $mm -= 12; $yyyy++; } if ( $interval == 0 ) { @t = localtime(time); $dd = $t[3]; $mm = $t[4] + 1; $yyyy = $t[5] + 1900; $bd = 0; } } } else { if ( ++$mm > 12 ) { $mm -= 12; $yyyy++; } } $mm--; @t = localtime( Time::Local::timelocal( 0, 0, 0, $dd, $mm, $yyyy ) - $bd ); $t[4]++; $t[4] = substr( "0$t[4]", -2 ); $t[3] = substr( "0$t[3]", -2 ); $t[5] += 1900; ( $self->format_date($fromdate), $self->format_date("$t[5]-$t[4]-$t[3]") ); } =item $form->audittrail($dbh, $myconfig, $audittrail); $audittrail is a hashref. If $audittrail->{id} is false, this function retrieves the current time from the database and return a string of the form "tablename|reference|formname|action|timestamp|" where all the values save timestamp are taken directly from the $audittrail hashref. If $audittrail->{id} is true but the value of audittrail in the defaults table is '0', do nothing and return. If $form->{audittrail} is true and $myconfig is false, $form->{audittrail} is treated as a pipe seperated list (trailing pipe required) of the form: table1|ref1|form1|action1|date1|...|tablen|refn|formn|actionn|daten| All the entries described by $form->{audittrail} are inserted into the audit table, taking on a transaction id of $audittrail->{id} and the employee id of the calling user. Irrespective of $form->{audittrail} and $myconfig status, this function will add a record to the audittrail using the values contained within $audittrail, substituting the current date if $audittrail->{transdate} is not set and the employee id of the calling user. =cut sub audittrail { my ( $self, $dbh, $myconfig, $audittrail ) = @_; # table, $reference, $formname, $action, $id, $transdate) = @_; my $query; my $rv; my $disconnect; if ( !$dbh ) { $dbh = $self->{dbh}; } my $sth; my $query; # if we have an id add audittrail, otherwise get a new timestamp my @queryargs; if ( $audittrail->{id} ) { $query = qq| SELECT value FROM defaults WHERE setting_key = 'audittrail'|; if ( $dbh->selectrow_array($query) ) { my ( $null, $employee_id ) = $self->get_employee($dbh); if ( $self->{audittrail} && !$myconfig ) { chop $self->{audittrail}; my @a = split /\|/, $self->{audittrail}; my %newtrail = (); my $key; my $i; my @flds = qw(tablename reference formname action transdate); # put into hash and remove dups while (@a) { $key = "$a[2]$a[3]"; $i = 0; $newtrail{$key} = { map { $_ => $a[ $i++ ] } @flds }; splice @a, 0, 5; } $query = qq| INSERT INTO audittrail (trans_id, tablename, reference, formname, action, transdate, employee_id) VALUES (?, ?, ?, ?, ?, ?, ?)|; my $sth = $dbh->prepare($query) || $self->dberror($query); foreach $key ( sort { $newtrail{$a}{transdate} cmp $newtrail{$b}{transdate} } keys %newtrail ) { $i = 2; $sth->bind_param( 1, $audittrail->{id} ); for (@flds) { $sth->bind_param( $i++, $newtrail{$key}{$_} ); } $sth->bind_param( $i++, $employee_id ); $sth->execute() || $self->dberror($query); $sth->finish; } } if ( $audittrail->{transdate} ) { $query = qq| INSERT INTO audittrail ( trans_id, tablename, reference, formname, action, employee_id, transdate) VALUES (?, ?, ?, ?, ?, ?, ?)|; @queryargs = ( $audittrail->{id}, $audittrail->{tablename}, $audittrail->{reference}, $audittrail->{formname}, $audittrail->{action}, $employee_id, $audittrail->{transdate} ); } else { $query = qq| INSERT INTO audittrail (trans_id, tablename, reference, formname, action, employee_id) VALUES (?, ?, ?, ?, ?, ?)|; @queryargs = ( $audittrail->{id}, $audittrail->{tablename}, $audittrail->{reference}, $audittrail->{formname}, $audittrail->{action}, $employee_id, ); } $sth = $dbh->prepare($query); $sth->execute(@queryargs) || $self->dberror($query); } } else { $query = qq|SELECT current_timestamp|; my ($timestamp) = $dbh->selectrow_array($query); $rv = "$audittrail->{tablename}|$audittrail->{reference}|$audittrail->{formname}|$audittrail->{action}|$timestamp|"; } $rv; } 1; =back