summaryrefslogtreecommitdiff
path: root/LedgerSMB/Form.pm
blob: 3d43b8a69ee80b1b8e98dcbed0f402be73789d81 (plain)
  1. =head1 NAME
  2. Form
  3. =head1 SYNOPSIS
  4. This module provides general legacy support functions and the central object
  5. =head1 STATUS
  6. Deprecated
  7. =head1 COPYRIGHT
  8. #====================================================================
  9. # LedgerSMB
  10. # Small Medium Business Accounting software
  11. # http://www.ledgersmb.org/
  12. #
  13. # Copyright (C) 2006
  14. # This work contains copyrighted information from a number of sources
  15. # all used with permission.
  16. #
  17. # This file contains source code included with or based on SQL-Ledger
  18. # which is Copyright Dieter Simader and DWS Systems Inc. 2000-2005
  19. # and licensed under the GNU General Public License version 2 or, at
  20. # your option, any later version. For a full list including contact
  21. # information of contributors, maintainers, and copyright holders,
  22. # see the CONTRIBUTORS file.
  23. #
  24. # Original Copyright Notice from SQL-Ledger 2.6.17 (before the fork):
  25. # Copyright (C) 2000
  26. #
  27. # Author: DWS Systems Inc.
  28. # Web: http://www.sql-ledger.org
  29. #
  30. # Contributors: Thomas Bayen <bayen@gmx.de>
  31. # Antti Kaihola <akaihola@siba.fi>
  32. # Moritz Bunkus (tex)
  33. # Jim Rawlings <jim@your-dba.com> (DB2)
  34. #====================================================================
  35. #
  36. # This file has undergone whitespace cleanup.
  37. #
  38. #====================================================================
  39. #
  40. # main package
  41. #
  42. #====================================================================
  43. =head1 METHODS
  44. =over
  45. =cut
  46. #inline documentation
  47. use strict;
  48. use Math::BigFloat lib => 'GMP';
  49. use LedgerSMB::Sysconfig;
  50. use List::Util qw(first);
  51. use Time::Local;
  52. use Cwd;
  53. use File::Copy;
  54. use charnames ':full';
  55. use open ':utf8';
  56. package Form;
  57. =item new Form([$argstr])
  58. Returns a reference to new Form object. The initial set of attributes is
  59. obtained from $argstr, a CGI query string, or $ARGV[0]. All the values are
  60. run through unescape to undo any URI encoding.
  61. The version and dbversion attributes are set to hardcoded values; action,
  62. nextsub, path, script, and login are filtered to remove some dangerous values.
  63. Both menubar and lynx are set if path matches lynx.
  64. $form->error may be called to deny access on some attribute values.
  65. =cut
  66. sub new {
  67. my $type = shift;
  68. my $argstr = shift;
  69. if ($ENV{CONTENT_LENGTH} > $LedgerSMB::Sysconfig::max_post_size) {
  70. print "Status: 413\n Request entity too large\n\n";
  71. die "Error: Request entity too large\n";
  72. }
  73. read( STDIN, $_, $ENV{CONTENT_LENGTH} );
  74. if ($argstr) {
  75. $_ = $argstr;
  76. }
  77. elsif ( $ENV{QUERY_STRING} ) {
  78. $_ = $ENV{QUERY_STRING};
  79. }
  80. elsif ( $ARGV[0] ) {
  81. $_ = $ARGV[0];
  82. }
  83. my $self = {};
  84. %$self = split /[&=]/;
  85. for ( keys %$self ) { $self->{$_} = unescape( "", $self->{$_} ) }
  86. if ( substr( $self->{action}, 0, 1 ) !~ /( |\.)/ ) {
  87. $self->{action} = lc $self->{action};
  88. $self->{action} =~ s/( |-|,|\#|\/|\.$)/_/g;
  89. $self->{nextsub} = lc $self->{nextsub};
  90. $self->{nextsub} =~ s/( |-|,|\#|\/|\.$)/_/g;
  91. }
  92. $self->{login} =~ s/[^a-zA-Z0-9._+\@'-]//g;
  93. if (!$self->{company} && $ENV{HTTP_COOKIE}){
  94. $ENV{HTTP_COOKIE} =~ s/;\s*/;/g;
  95. my %cookie;
  96. my @cookies = split /;/, $ENV{HTTP_COOKIE};
  97. foreach (@cookies) {
  98. my ( $name, $value ) = split /=/, $_, 2;
  99. $cookie{$name} = $value;
  100. }
  101. my $ccookie = $cookie{LedgerSMB};
  102. $ccookie =~ s/.*:([^:]*)$/$1/;
  103. $self->{company} = $ccookie;
  104. }
  105. $self->{menubar} = 1 if $self->{path} =~ /lynx/i;
  106. #menubar will be deprecated, replaced with below
  107. $self->{lynx} = 1 if $self->{path} =~ /lynx/i;
  108. $self->{version} = "SVN Trunk";
  109. $self->{dbversion} = "1.2.0";
  110. bless $self, $type;
  111. if ( $self->{path} ne 'bin/lynx' ) { $self->{path} = 'bin/mozilla'; }
  112. if ( ( $self->{script} )
  113. and not List::Util::first { $_ eq $self->{script} }
  114. @{LedgerSMB::Sysconfig::scripts} )
  115. {
  116. $self->error( 'Access Denied', __LINE__, __FILE__ );
  117. }
  118. if ( ( $self->{action} =~ /(:|')/ ) || ( $self->{nextsub} =~ /(:|')/ ) ) {
  119. $self->error( "Access Denied", __LINE__, __FILE__ );
  120. }
  121. for ( keys %$self ) { $self->{$_} =~ s/\N{NULL}//g }
  122. if ( ($self->{action} eq 'redirect') || ($self->{nextsub} eq 'redirect') ) {
  123. $self->error( "Access Denied", __LINE__, __FILE__ );
  124. }
  125. $self;
  126. }
  127. =item $form->debug([$file]);
  128. Outputs the sorted contents of $form. If a filename is specified, log to it,
  129. otherwise output to STDOUT.
  130. =cut
  131. sub debug {
  132. my ( $self, $file ) = @_;
  133. if ($file) {
  134. open( FH, '>', "$file" ) or die $!;
  135. for ( sort keys %$self ) { print FH "$_ = $self->{$_}\n" }
  136. close(FH);
  137. }
  138. else {
  139. print "\n";
  140. for ( sort keys %$self ) { print "$_ = $self->{$_}\n" }
  141. }
  142. }
  143. =item $form->encode_all();
  144. Does nothing and is unused. Contains merely the comment # TODO;
  145. =cut
  146. sub encode_all {
  147. # TODO;
  148. }
  149. =item $form->decode_all();
  150. Does nothing and is unused. Contains merely the comment # TODO
  151. =cut
  152. sub decode_all {
  153. # TODO
  154. }
  155. =item $form->escape($str[, $beenthere]);
  156. Returns the URI-encoded $str. $beenthere is a boolean that when true forces a
  157. single encoding run. When false, it escapes the string twice if it detects
  158. that it is running on a version of Apache 2.0 earlier than 2.0.44.
  159. Note that recurring transaction support depends on this function escaping ','.
  160. =cut
  161. sub escape {
  162. my ( $self, $str, $beenthere ) = @_;
  163. # for Apache 2 we escape strings twice
  164. if ( ( $ENV{SERVER_SIGNATURE} =~ /Apache\/2\.(\d+)\.(\d+)/ )
  165. && !$beenthere )
  166. {
  167. $str = $self->escape( $str, 1 ) if $1 == 0 && $2 < 44;
  168. }
  169. utf8::encode($str);
  170. # SC: Adding commas to the ignore list will break recurring transactions
  171. $str =~ s/([^a-zA-Z0-9_.-])/sprintf("%%%02x", ord($1))/ge;
  172. $str;
  173. }
  174. =item $form->unescape($str);
  175. Returns the unencoded form of the URI-encoded $str.
  176. =cut
  177. sub unescape {
  178. my ( $self, $str ) = @_;
  179. $str =~ tr/+/ /;
  180. $str =~ s/\\$//;
  181. utf8::encode($str) if utf8::is_utf8($str);
  182. $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
  183. utf8::decode($str);
  184. $str =~ s/\r?\n/\n/g;
  185. $str;
  186. }
  187. =item $form->quote($str);
  188. Replaces all double quotes in $str with '&quot;'. Does nothing if $str is a
  189. reference.
  190. =cut
  191. sub quote {
  192. my ( $self, $str ) = @_;
  193. if ( $str && !ref($str) ) {
  194. $str =~ s/"/&quot;/g;
  195. }
  196. $str;
  197. }
  198. =item $form->unquote($str);
  199. Replaces all '&quot;' in $str with double quotes. Does nothing if $str is a
  200. reference.
  201. =cut
  202. sub unquote {
  203. my ( $self, $str ) = @_;
  204. if ( $str && !ref($str) ) {
  205. $str =~ s/&quot;/"/g;
  206. }
  207. $str;
  208. }
  209. =item $form->hide_form([...]);
  210. Outputs hidden HTML form fields to STDOUT. If values are passed into this
  211. function, only those $form values are output. If no values are passed in, all
  212. $form values are output as well as deleting $form->{header}. Values from the
  213. $form object are run through $form->quote, whereas keys/names are not.
  214. Sample output:
  215. <input type="hidden" name="login" value="testuser" />
  216. =cut
  217. sub hide_form {
  218. my $self = shift;
  219. if (@_) {
  220. for (@_) {
  221. print qq|<input type="hidden" name="$_" value="|
  222. . $self->quote( $self->{$_} )
  223. . qq|" />\n|;
  224. }
  225. }
  226. else {
  227. delete $self->{header};
  228. for ( sort keys %$self ) {
  229. print qq|<input type="hidden" name="$_" value="|
  230. . $self->quote( $self->{$_} )
  231. . qq|" />\n|;
  232. }
  233. }
  234. }
  235. =item $form->error($msg);
  236. Output an error message, $msg. If a CGI environment is detected, this outputs
  237. an HTTP and HTML header section if required, and displays the message after
  238. running it through $form->format_string. If it is not a CGI environment and
  239. $ENV{error_function} is set, call the specified function with $msg as the sole
  240. argument. Otherwise, this function simply dies with $msg.
  241. This function does not return. Execution is terminated at the end of the
  242. appropriate path.
  243. =cut
  244. sub error {
  245. my ( $self, $msg ) = @_;
  246. if ( $ENV{GATEWAY_INTERFACE} ) {
  247. $self->{msg} = $msg;
  248. $self->{format} = "html";
  249. $self->format_string('msg');
  250. delete $self->{pre};
  251. if ( !$self->{header} ) {
  252. $self->header;
  253. }
  254. print
  255. qq|<body><h2 class="error">Error!</h2> <p><b>$self->{msg}</b></body>|;
  256. exit;
  257. }
  258. else {
  259. if ( $ENV{error_function} ) {
  260. __PACKAGE__->can($ENV{error_function})->($msg);
  261. }
  262. die "Error: $msg\n";
  263. }
  264. }
  265. =item $form->info($msg);
  266. Output an informational message, $msg. If a CGI environment is detected, this
  267. outputs an HTTP and HTML header section if required, and displays the message
  268. in bold tags without escaping. If it is not a CGI environment and
  269. $ENV{info_function} is set, call the specified function with $msg as the sole
  270. argument. Otherwise, this function simply prints $msg to STDOUT.
  271. =cut
  272. sub info {
  273. my ( $self, $msg ) = @_;
  274. if ( $ENV{GATEWAY_INTERFACE} ) {
  275. $msg =~ s/\n/<br>/g;
  276. delete $self->{pre};
  277. if ( !$self->{header} ) {
  278. $self->header;
  279. print qq| <body>|;
  280. $self->{header} = 1;
  281. }
  282. print "<b>$msg</b>";
  283. }
  284. else {
  285. if ( $ENV{info_function} ) {
  286. __PACKAGE__->can($ENV{info_function})->($msg);
  287. }
  288. else {
  289. print "$msg\n";
  290. }
  291. }
  292. }
  293. =item $form->numtextrows($str, $cols[, $maxrows]);
  294. Returns the number of rows of $cols columns can be formed by $str. If $maxrows
  295. is set and the number of rows is greater than $maxrows, this returns $maxrows.
  296. In the determination of rowcount, newline characters, "\n", are taken into
  297. account while spaces are not.
  298. =cut
  299. sub numtextrows {
  300. my ( $self, $str, $cols, $maxrows ) = @_;
  301. my $rows = 0;
  302. for ( split /\n/, $str ) {
  303. $rows += int( ( (length) - 2 ) / $cols ) + 1;
  304. }
  305. $maxrows = $rows unless defined $maxrows;
  306. return ( $rows > $maxrows ) ? $maxrows : $rows;
  307. }
  308. =item $form->dberror($msg);
  309. Outputs a message as in $form->error but with $DBI::errstr automatically
  310. appended to $msg.
  311. =cut
  312. sub dberror {
  313. my ( $self, $msg ) = @_;
  314. $self->error( "$msg\n" . $DBI::errstr );
  315. }
  316. =item $form->isblank($name, $msg);
  317. Calls $form->error($msg) if the value of $form->{$name} matches /^\s*$/.
  318. =cut
  319. sub isblank {
  320. my ( $self, $name, $msg ) = @_;
  321. $self->error($msg) if $self->{$name} =~ /^\s*$/;
  322. }
  323. =item $form->header([$init, $headeradd]);
  324. Outputs HTML and HTTP headers and sets $form->{header} to indicate that headers
  325. have been output. If called with $form->{header} set or in a non-CGI
  326. environment, does not output anything. $init is ignored. $headeradd is data
  327. to be added to the <head> portion of the output headers. $form->{stylesheet},
  328. $form->{title}, $form->{titlebar}, and $form->{pre} all affect the output of
  329. this function.
  330. If the stylesheet indicated by $form->{stylesheet} exists, output a link tag
  331. to reference it. If $form->{title} is false, the title text is the value of
  332. $form->{titlebar}. If $form->{title} is true, the title text takes the form of
  333. "$form->{title} - $form->{titlebar}". The value of $form->{pre} is output
  334. immediately after the closing of <head>.
  335. =cut
  336. sub header {
  337. my ( $self, $init, $headeradd ) = @_;
  338. return if $self->{header};
  339. my ( $stylesheet, $favicon, $charset );
  340. if ( $ENV{GATEWAY_INTERFACE} ) {
  341. if ( $self->{stylesheet} && ( -f "css/$self->{stylesheet}" ) ) {
  342. $stylesheet =
  343. qq|<link rel="stylesheet" href="css/$self->{stylesheet}" type="text/css" title="LedgerSMB stylesheet" />\n|;
  344. }
  345. $self->{charset} ||= "utf-8";
  346. $charset =
  347. qq|<meta http-equiv="content-type" content="text/html; charset=$self->{charset}" />\n|;
  348. $self->{titlebar} =
  349. ( $self->{title} )
  350. ? "$self->{title} - $self->{titlebar}"
  351. : $self->{titlebar};
  352. print qq|Content-Type: text/html; charset=utf-8\n\n
  353. <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
  354. "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
  355. <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
  356. <head>
  357. <title>$self->{titlebar}</title>
  358. <meta http-equiv="Pragma" content="no-cache" />
  359. <meta http-equiv="Expires" content="-1" />
  360. <link rel="shortcut icon" href="favicon.ico" type="image/x-icon" />
  361. $stylesheet
  362. $charset
  363. <meta name="robots" content="noindex,nofollow" />
  364. $headeradd
  365. </head>
  366. $self->{pre} \n|;
  367. }
  368. $self->{header} = 1;
  369. }
  370. =item $form->redirect([$msg]);
  371. If $form->{callback} is set or $msg is not set, call the redirect function in
  372. common.pl. If main::redirect returns, exit.
  373. Otherwise, output $msg as an informational message with $form->info($msg).
  374. =cut
  375. sub redirect {
  376. my ( $self, $msg ) = @_;
  377. if ( $self->{callback} || !$msg ) {
  378. main::redirect();
  379. exit;
  380. }
  381. else {
  382. $self->info($msg);
  383. }
  384. }
  385. =item $form->sort_columns(@columns);
  386. Sorts the list @columns. If $form->{sort} is unset, do nothing. If the value
  387. of $form->{sort} does not exist in @columns, returns the list formed by the
  388. value of $form->{sort} followed by the values of @columns. If the value of
  389. $form->{sort} is in @columns, return the list formed by @columns with the value
  390. of $form->{sort} moved to the head of the list.
  391. =cut
  392. sub sort_columns {
  393. my ( $self, @columns ) = @_;
  394. if ( $self->{sort} ) {
  395. $self->{sort} =~ s/^"*(.*?)"*$/$1/;
  396. if (@columns) {
  397. @columns = grep !/^$self->{sort}$/, @columns;
  398. if ($self->{sort} !~ /^\w*$/){
  399. $self->{sort} = $self->{dbh}->quote_identifier($self->{sort});
  400. }
  401. splice @columns, 0, 0, $self->{sort};
  402. }
  403. }
  404. @columns;
  405. }
  406. =item $form->sort_order($columns[, $ordinal]);
  407. Returns a string that contains ordering details for the columns in SQL form.
  408. $columns is a reference to a list of columns, $ordinal is a reference to a hash
  409. that maps column names to ordinal positions. This function depends upon the
  410. values of $form->{direction}, $form->{sort}, and $form->{oldsort}.
  411. If $form->{direction} is false, it becomes 'ASC'. If $form->{direction} is true
  412. and $form->{sort} and $form->{oldsort} are equal, reverse the order specified by
  413. $form->{direction}. $form->{oldsort} is set to the same value as $form->{sort}
  414. The actual sorting of $columns happens as in $form->sort_columns(@$columns).
  415. If $ordinal is set, the positions given by it are substituted for the names of
  416. columns returned.
  417. =cut
  418. sub sort_order {
  419. my ( $self, $columns, $ordinal ) = @_;
  420. # setup direction
  421. if ( $self->{direction} ) {
  422. if ( $self->{sort} eq $self->{oldsort} ) {
  423. if ( $self->{direction} eq 'ASC' ) {
  424. $self->{direction} = "DESC";
  425. }
  426. else {
  427. $self->{direction} = "ASC";
  428. }
  429. }
  430. }
  431. else {
  432. $self->{direction} = "ASC";
  433. }
  434. $self->{oldsort} = $self->{sort};
  435. my @a = $self->sort_columns( @{$columns} );
  436. if (ref $ordinal eq 'HASH') {
  437. $a[0] =
  438. ( $ordinal->{ $a[$_] } )
  439. ? "$ordinal->{$a[0]} $self->{direction}"
  440. : "$a[0] $self->{direction}";
  441. for ( 1 .. $#a ) {
  442. $a[$_] = $ordinal->{ $a[$_] } if $ordinal->{ $a[$_] };
  443. }
  444. }
  445. else {
  446. $a[0] .= " $self->{direction}";
  447. }
  448. my $sortorder = join ',', @a;
  449. $sortorder;
  450. }
  451. =item $form->format_amount($myconfig, $amount, $places, $dash);
  452. Returns $amount as formatted in the form specified by $form->{numberformat}.
  453. $places is the number of decimal places to have in the output. $dash indicates
  454. how to represent conditions surrounding values.
  455. +-------+----------+---------+------+
  456. | $dash | -1.00 | 1.00 | 0.00 |
  457. +-------+----------+---------+------+
  458. | - | (1.00) | 1.00 | - |
  459. | DRCR | 1.00 DR | 1.00 CR | DRCR |
  460. | 0 | -1.00 | 1.00 | 0.00 |
  461. | x | -1.00 | 1.00 | x |
  462. | undef | -1.00 | 1.00 | |
  463. +-------+----------+---------+------+
  464. Sample behaviour of the formatted output of various numbers for select $dash
  465. values.
  466. =cut
  467. sub format_amount {
  468. my ( $self, $myconfig, $amount, $places, $dash ) = @_;
  469. my $negative;
  470. if ($amount) {
  471. $amount = $self->parse_amount( $myconfig, $amount );
  472. $negative = ( $amount < 0 );
  473. $amount =~ s/-//;
  474. }
  475. if ( $places =~ /\d+/ ) {
  476. #$places = 4 if $places == 2;
  477. $amount = $self->round_amount( $amount, $places );
  478. }
  479. # is the amount negative
  480. # Parse $myconfig->{numberformat}
  481. my ( $ts, $ds ) = ( $1, $2 );
  482. if ($amount) {
  483. if ( $myconfig->{numberformat} ) {
  484. my ( $whole, $dec ) = split /\./, "$amount";
  485. $amount = join '', reverse split //, $whole;
  486. if ($places) {
  487. $dec .= "0" x $places;
  488. $dec = substr( $dec, 0, $places );
  489. }
  490. if ( $myconfig->{numberformat} eq '1,000.00' ) {
  491. $amount =~ s/\d{3,}?/$&,/g;
  492. $amount =~ s/,$//;
  493. $amount = join '', reverse split //, $amount;
  494. $amount .= "\.$dec" if ( $dec ne "" );
  495. }
  496. elsif ( $myconfig->{numberformat} eq '1 000.00' ) {
  497. $amount =~ s/\d{3,}?/$& /g;
  498. $amount =~ s/\s$//;
  499. $amount = join '', reverse split //, $amount;
  500. $amount .= "\.$dec" if ( $dec ne "" );
  501. }
  502. elsif ( $myconfig->{numberformat} eq "1'000.00" ) {
  503. $amount =~ s/\d{3,}?/$&'/g;
  504. $amount =~ s/'$//;
  505. $amount = join '', reverse split //, $amount;
  506. $amount .= "\.$dec" if ( $dec ne "" );
  507. }
  508. elsif ( $myconfig->{numberformat} eq '1.000,00' ) {
  509. $amount =~ s/\d{3,}?/$&./g;
  510. $amount =~ s/\.$//;
  511. $amount = join '', reverse split //, $amount;
  512. $amount .= ",$dec" if ( $dec ne "" );
  513. }
  514. elsif ( $myconfig->{numberformat} eq '1000,00' ) {
  515. $amount = "$whole";
  516. $amount .= ",$dec" if ( $dec ne "" );
  517. }
  518. elsif ( $myconfig->{numberformat} eq '1000.00' ) {
  519. $amount = "$whole";
  520. $amount .= ".$dec" if ( $dec ne "" );
  521. }
  522. if ( $dash =~ /-/ ) {
  523. $amount = ($negative) ? "($amount)" : "$amount";
  524. }
  525. elsif ( $dash =~ /DRCR/ ) {
  526. $amount = ($negative) ? "$amount DR" : "$amount CR";
  527. }
  528. else {
  529. $amount = ($negative) ? "-$amount" : "$amount";
  530. }
  531. }
  532. }
  533. else {
  534. if ( $dash eq "0" && $places ) {
  535. if ( $myconfig->{numberformat} =~ /0,00$/ ) {
  536. $amount = "0" . "," . "0" x $places;
  537. }
  538. else {
  539. $amount = "0" . "." . "0" x $places;
  540. }
  541. }
  542. else {
  543. $amount = ( $dash ne "" ) ? "$dash" : "";
  544. }
  545. }
  546. $amount;
  547. }
  548. =item $form->parse_amount($myconfig, $amount);
  549. Return a Math::BigFloat containing the value of $amount where $amount is
  550. formatted as $myconfig->{numberformat}. If $amount is '' or undefined, it is
  551. treated as zero. DRCR and parenthesis notation is accepted in addition to
  552. negative sign notation.
  553. Calls $form->error if the value is NaN.
  554. =cut
  555. sub parse_amount {
  556. my ( $self, $myconfig, $amount ) = @_;
  557. if ( ( $amount eq '' ) or ( ! defined $amount ) ) {
  558. $amount = 0;
  559. }
  560. if ( UNIVERSAL::isa( $amount, 'Math::BigFloat' ) )
  561. { # Amount may not be an object
  562. return $amount;
  563. }
  564. my $numberformat = $myconfig->{numberformat};
  565. if ( ( $numberformat eq '1.000,00' )
  566. || ( $numberformat eq '1000,00' ) )
  567. {
  568. $amount =~ s/\.//g;
  569. $amount =~ s/,/./;
  570. }
  571. elsif ( $numberformat eq '1 000.00' ) {
  572. $amount =~ s/\s//g;
  573. }
  574. elsif ( $numberformat eq "1'000.00" ) {
  575. $amount =~ s/'//g;
  576. }
  577. $amount =~ s/,//g;
  578. if ( $amount =~ s/\((\d*\.?\d*)\)/$1/ ) {
  579. $amount = $1 * -1;
  580. }
  581. elsif ( $amount =~ s/(\d*\.?\d*)\s?DR/$1/ ) {
  582. $amount = $1 * -1;
  583. }
  584. $amount =~ s/\s?CR//;
  585. $amount =~ /(\d*)\.(\d*)/;
  586. my $decimalplaces = length $1 + length $2;
  587. $amount = new Math::BigFloat($amount);
  588. if ($amount->is_nan){
  589. $self->error("Invalid number detected during parsing");
  590. }
  591. return ( $amount * 1 );
  592. }
  593. =item $form->round_amount($amount, $places);
  594. Rounds the provided $amount to $places decimal places.
  595. =cut
  596. sub round_amount {
  597. my ( $self, $amount, $places ) = @_;
  598. # These rounding rules follow from the previous implementation.
  599. # They should be changed to allow different rules for different accounts.
  600. Math::BigFloat->round_mode('+inf') if $amount >= 0;
  601. Math::BigFloat->round_mode('-inf') if $amount < 0;
  602. $amount = Math::BigFloat->new($amount)->ffround( -$places ) if $places >= 0;
  603. $amount = Math::BigFloat->new($amount)->ffround( -( $places - 1 ) )
  604. if $places < 0;
  605. $amount->precision(undef); #we are assuming whole cents so do not round
  606. #immediately on arithmatic. This is necessary
  607. #because Math::BigFloat is arithmatically
  608. #correct wrt accuracy and precision.
  609. return $amount;
  610. }
  611. =item $form->db_parse_numeric('sth' => $sth, ['arrayref' => $arrayref, 'hashref' => $hashref])
  612. Converts numeric values in the result set $arrayref or $hashref to
  613. Math::BigFloat using $sth to determine which fields are numeric.
  614. =cut
  615. sub db_parse_numeric {
  616. my $self = shift;
  617. my %args = @_;
  618. my ($sth, $arrayref, $hashref) = ($args{sth}, $args{arrayref},
  619. $args{hashref});
  620. my @types = @{$sth->{TYPE}};
  621. my @names = @{$sth->{NAME_lc}};
  622. for (0 .. $#names){
  623. # numeric float4/real
  624. if ($types[$_] == 3 or $types[$_] ==2) {
  625. $arrayref->[$_] = Math::BigFloat->new($arrayref->[$_])
  626. if defined $arrayref;
  627. $hashref->{$names[$_]} = Math::BigFloat->new($hashref->{$names[$_]})
  628. if defined $hashref;
  629. }
  630. }
  631. return ($hashref || $arrayref);
  632. }
  633. =item $form->get_my_emp_num($myconfig);
  634. Function to get the employee number of the user $form->{login}. $myconfig is
  635. only used to create %myconfig. $form->{emp_num} is set to the retrieved value.
  636. This function is currently (2007-08-02) only used by pos.conf.pl.
  637. =cut
  638. sub get_my_emp_num {
  639. my ( $self, $myconfig) = @_;
  640. my %myconfig = %{$myconfig};
  641. my $dbh = $self->{dbh};
  642. # we got a connection, check the version
  643. my $query = qq|
  644. SELECT employeenumber FROM employee
  645. WHERE login = ?|;
  646. my $sth = $dbh->prepare($query);
  647. $sth->execute( $self->{login} ) || $self->dberror($query);
  648. my ($id) = $sth->fetchrow_array;
  649. $sth->finish;
  650. $self->{'emp_num'} = $id;
  651. }
  652. =item $form->format_string(@fields);
  653. Escape the values of $form selected by @fields for the format specified by
  654. $form->{format}.
  655. =cut
  656. sub format_string {
  657. my ( $self, @fields ) = @_;
  658. my $format = $self->{format};
  659. if ( $self->{format} =~ /(postscript|pdf)/ ) {
  660. $format = 'tex';
  661. }
  662. my %replace = (
  663. 'order' => {
  664. html => [ '<', '>', '\n', '\r' ],
  665. txt => [ '\n', '\r' ],
  666. tex => [
  667. quotemeta('\\'), '&', '\n', '\r',
  668. '\$', '%', '_', '#',
  669. quotemeta('^'), '{', '}', '<',
  670. '>', '£'
  671. ]
  672. },
  673. html => {
  674. '<' => '&lt;',
  675. '>' => '&gt;',
  676. '\n' => '<br />',
  677. '\r' => '<br />'
  678. },
  679. txt => { '\n' => "\n", '\r' => "\r" },
  680. tex => {
  681. '&' => '\&',
  682. '$' => '\$',
  683. '%' => '\%',
  684. '_' => '\_',
  685. '#' => '\#',
  686. quotemeta('^') => '\^\\',
  687. '{' => '\{',
  688. '}' => '\}',
  689. '<' => '$<$',
  690. '>' => '$>$',
  691. '\n' => '\newline ',
  692. '\r' => '\newline ',
  693. '£' => '\pounds ',
  694. quotemeta('\\') => '/'
  695. }
  696. );
  697. my $key;
  698. foreach $key ( @{ $replace{order}{$format} } ) {
  699. for (@fields) { $self->{$_} =~ s/$key/$replace{$format}{$key}/g }
  700. }
  701. }
  702. =item $form->datetonum($myconfig, $date[, $picture]);
  703. Converts $date from the format $myconfig->{dateformat} to the format 'yyyymmdd'.
  704. If the year extracted is only two-digits, the year given is assumed to be in the
  705. range 2000-2099.
  706. If $date does not contain any non-digits, datetonum does nothing.
  707. $picture is ignored.
  708. =cut
  709. sub datetonum {
  710. my ( $self, $myconfig, $date, $picture ) = @_;
  711. if ($date =~ /^\d{4}-\d{2}-\d{2}$/){
  712. $date =~ s/-//g;
  713. return $date;
  714. }
  715. if ( $date && $date =~ /\D/ ) {
  716. my $yy;
  717. my $mm;
  718. my $dd;
  719. if ( $date =~ /^\d{4}-\d\d-\d\d$/ ) {
  720. ( $yy, $mm, $dd ) = split /\D/, $date;
  721. } if ( $myconfig->{dateformat} =~ /^yy/ ) {
  722. ( $yy, $mm, $dd ) = split /\D/, $date;
  723. } elsif ( $myconfig->{dateformat} =~ /^mm/ ) {
  724. ( $mm, $dd, $yy ) = split /\D/, $date;
  725. } elsif ( $myconfig->{dateformat} =~ /^dd/ ) {
  726. ( $dd, $mm, $yy ) = split /\D/, $date;
  727. }
  728. $dd *= 1;
  729. $mm *= 1;
  730. $yy += 2000 if length $yy == 2;
  731. $dd = substr( "0$dd", -2 );
  732. $mm = substr( "0$mm", -2 );
  733. $date = "$yy$mm$dd";
  734. }
  735. $date;
  736. }
  737. =item $form->add_date($myconfig, $date, $repeat, $unit);
  738. Returns the date $repeat $units from $date in the input format. $date can
  739. either be in $myconfig->{dateformat} or 'yyyymmdd' (four digit year required for
  740. this option). The valid values for $unit are 'days', 'weeks', 'months', and
  741. 'years'.
  742. This function is unreliable for $unit values other than 'days' or 'weeks' and
  743. can die horribly.
  744. =cut
  745. sub add_date {
  746. my ( $self, $myconfig, $date, $repeat, $unit ) = @_;
  747. my $diff = 0;
  748. my $spc = $myconfig->{dateformat};
  749. my $yy;
  750. my $mm;
  751. my $dd;
  752. $spc =~ s/\w//g;
  753. $spc = substr( $spc, 0, 1 );
  754. if ($date) {
  755. if ( $date =~ /\D/ ) {
  756. if ( $myconfig->{dateformat} =~ /^yy/ ) {
  757. ( $yy, $mm, $dd ) = split /\D/, $date;
  758. }
  759. elsif ( $myconfig->{dateformat} =~ /^mm/ ) {
  760. ( $mm, $dd, $yy ) = split /\D/, $date;
  761. }
  762. elsif ( $myconfig->{dateformat} =~ /^dd/ ) {
  763. ( $dd, $mm, $yy ) = split /\D/, $date;
  764. }
  765. }
  766. else {
  767. # ISO
  768. ( $yy, $mm, $dd ) = ($date =~ /(....)(..)(..)/);
  769. }
  770. if ( $unit eq 'days' ) {
  771. $diff = $repeat * 86400;
  772. }
  773. elsif ( $unit eq 'weeks' ) {
  774. $diff = $repeat * 604800;
  775. }
  776. elsif ( $unit eq 'months' ) {
  777. $diff = $mm + $repeat;
  778. my $whole = int( $diff / 12 );
  779. $yy += $whole;
  780. $mm = ( $diff % 12 );
  781. $mm = '12' if $mm == 0;
  782. $yy-- if $mm == 12;
  783. $diff = 0;
  784. }
  785. elsif ( $unit eq 'years' ) {
  786. $yy += $repeat;
  787. }
  788. $mm--;
  789. my @t = localtime( Time::Local::timelocal( 0, 0, 0, $dd, $mm, $yy ) + $diff );
  790. $t[4]++;
  791. $mm = substr( "0$t[4]", -2 );
  792. $dd = substr( "0$t[3]", -2 );
  793. $yy = $t[5] + 1900;
  794. if ( $date =~ /\D/ ) {
  795. if ( $myconfig->{dateformat} =~ /^yy/ ) {
  796. $date = "$yy$spc$mm$spc$dd";
  797. }
  798. elsif ( $myconfig->{dateformat} =~ /^mm/ ) {
  799. $date = "$mm$spc$dd$spc$yy";
  800. }
  801. elsif ( $myconfig->{dateformat} =~ /^dd/ ) {
  802. $date = "$dd$spc$mm$spc$yy";
  803. }
  804. }
  805. else {
  806. $date = "$yy$mm$dd";
  807. }
  808. }
  809. $date;
  810. }
  811. =item $form->print_button($button, $name);
  812. Outputs a submit button to STDOUT. $button is a hashref that contains data
  813. about buttons, $name is the key for the element in $button to output. Each
  814. value in $button is a reference to a hash of two elements, 'key' and 'value'.
  815. $name is the value of the button that gets sent to the server when clicked,
  816. $button->{$name}{key} is the accesskey, and $button->{$name}{value} is the label
  817. for the button.
  818. =cut
  819. sub print_button {
  820. my ( $self, $button, $name ) = @_;
  821. print
  822. qq|<button class="submit" type="submit" name="action" value="$name" accesskey="$button->{$name}{key}" title="$button->{$name}{value} [Alt-$button->{$name}{key}]">$button->{$name}{value}</button>\n|;
  823. }
  824. # Database routines used throughout
  825. =item $form->db_init($myconfig);
  826. Connect to the database that $myconfig is set to use and initialise the base
  827. parameters. The connection handle becomes $form->{dbh} and
  828. $form->{custom_db_fields} is populated. The connection initiated has
  829. autocommit disabled.
  830. =cut
  831. sub db_init {
  832. my ( $self, $myconfig ) = @_;
  833. # Handling of HTTP Basic Auth headers
  834. my $auth = $ENV{'HTTP_AUTHORIZATION'};
  835. $auth =~ s/Basic //i; # strip out basic authentication preface
  836. $auth = MIME::Base64::decode($auth);
  837. my ($login, $password) = split(/:/, $auth);
  838. $self->{login} = $login;
  839. if (!$self->{company}){
  840. $self->{company} = $LedgerSMB::Sysconfig::default_db;
  841. }
  842. my $dbname = $self->{company};
  843. my $dbconfig = { dbconnect => "dbi:Pg:dbname=$dbname",
  844. dbuser => $login,
  845. dbpasswd => $password
  846. };
  847. $self->{dbh} = $self->dbconnect_noauto($dbconfig) || $self->dberror();
  848. $self->{dbh}->{pg_server_prepare} = 0;
  849. my $dbh = $self->{dbh};
  850. my %date_query = (
  851. 'mm/dd/yy' => 'set DateStyle to \'SQL, US\'',
  852. 'mm-dd-yy' => 'set DateStyle to \'POSTGRES, US\'',
  853. 'dd/mm/yy' => 'set DateStyle to \'SQL, EUROPEAN\'',
  854. 'dd-mm-yy' => 'set DateStyle to \'POSTGRES, EUROPEAN\'',
  855. 'dd.mm.yy' => 'set DateStyle to \'GERMAN\''
  856. );
  857. $self->{dbh}->do( $date_query{ $myconfig->{dateformat} } );
  858. $self->{db_dateformat} = $myconfig->{dateformat}; #shim
  859. # This is the general version check
  860. my $sth = $dbh->prepare("
  861. SELECT value FROM defaults
  862. WHERE setting_key = 'version'");
  863. $sth->execute;
  864. my ($dbversion) = $sth->fetchrow_array;
  865. if ($dbversion ne $self->{dbversion}){
  866. $self->error("Database is not the expected version.");
  867. }
  868. my $query = "SELECT t.extends,
  869. coalesce (t.table_name, 'custom_' || extends)
  870. || ':' || f.field_name as field_def
  871. FROM custom_table_catalog t
  872. JOIN custom_field_catalog f USING (table_id)";
  873. my $sth = $self->{dbh}->prepare($query);
  874. $sth->execute;
  875. my $ref;
  876. while ( $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  877. push @{ $self->{custom_db_fields}{ $ref->{extends} } },
  878. $ref->{field_def};
  879. }
  880. }
  881. =item $form->run_custom_queries($tablename, $query_type[, $linenum]);
  882. Runs queries against custom fields for the specified $query_type against
  883. $tablename.
  884. Valid values for $query_type are any casing of 'SELECT', 'INSERT', and 'UPDATE'.
  885. =cut
  886. sub run_custom_queries {
  887. my ( $self, $tablename, $query_type, $linenum ) = @_;
  888. my $dbh = $self->{dbh};
  889. if ( $query_type !~ /^(select|insert|update)$/i ) {
  890. $self->error(
  891. "Passed incorrect query type to run_custom_queries."
  892. );
  893. }
  894. my @rc;
  895. my %temphash;
  896. my @templist;
  897. my @elements;
  898. my $query;
  899. my $did_insert;
  900. my $ins_values;
  901. my $sth;
  902. if ($linenum) {
  903. $linenum = "_$linenum";
  904. }
  905. $query_type = uc($query_type);
  906. for ( @{ $self->{custom_db_fields}{$tablename} } ) {
  907. @elements = split( /:/, $_ );
  908. push @{ $temphash{ $elements[0] } }, $elements[1];
  909. }
  910. for ( keys %temphash ) {
  911. my @data;
  912. my $ins_values;
  913. $query = "$query_type ";
  914. if ( $query_type eq 'UPDATE' ) {
  915. $query = "DELETE FROM $_ WHERE row_id = ?";
  916. my $sth = $dbh->prepare($query);
  917. $sth->execute( $self->{ "id" . "$linenum" } )
  918. || $self->dberror($query);
  919. }
  920. elsif ( $query_type eq 'INSERT' ) {
  921. $query .= " INTO $_ (";
  922. }
  923. my $first = 1;
  924. for ( @{ $temphash{$_} } ) {
  925. $query .= "$_";
  926. if ( $query_type eq 'UPDATE' ) {
  927. $query .= '= ?';
  928. }
  929. $ins_values .= "?, ";
  930. $query .= ", ";
  931. $first = 0;
  932. if ( $query_type eq 'UPDATE' or $query_type eq 'INSERT' ) {
  933. push @data, $self->{"$_$linenum"};
  934. }
  935. }
  936. if ( $query_type ne 'INSERT' ) {
  937. $query =~ s/, $//;
  938. }
  939. if ( $query_type eq 'SELECT' ) {
  940. $query .= " FROM $_";
  941. }
  942. if ( $query_type eq 'SELECT' or $query_type eq 'UPDATE' ) {
  943. $query .= " WHERE row_id = ?";
  944. }
  945. if ( $query_type eq 'INSERT' ) {
  946. $query .= " row_id) VALUES ($ins_values ?)";
  947. }
  948. if ( $query_type eq 'SELECT' ) {
  949. push @rc, [$query];
  950. }
  951. else {
  952. unshift( @data, $query );
  953. push @rc, [@data];
  954. }
  955. }
  956. if ( $query_type eq 'INSERT' ) {
  957. for (@rc) {
  958. $query = shift( @{$_} );
  959. $sth = $dbh->prepare($query)
  960. || $self->db_error($query);
  961. $sth->execute( @{$_}, $self->{id} )
  962. || $self->dberror($query);
  963. $sth->finish;
  964. $did_insert = 1;
  965. }
  966. }
  967. elsif ( $query_type eq 'UPDATE' ) {
  968. @rc = $self->run_custom_queries( $tablename, 'INSERT', $linenum );
  969. }
  970. elsif ( $query_type eq 'SELECT' ) {
  971. for (@rc) {
  972. my $query = shift @{$_};
  973. my $sth = $self->{dbh}->prepare($query);
  974. $sth->execute( $self->{id} );
  975. my $ref = $sth->fetchrow_hashref('NAME_lc');
  976. for ( keys %{$ref} ) {
  977. $self->{$_} = $ref->{$_};
  978. }
  979. }
  980. }
  981. @rc;
  982. }
  983. =item $form->dbconnect($myconfig);
  984. Returns an autocommit connection to the database specified in $myconfig.
  985. =cut
  986. sub dbconnect {
  987. my ( $self, $myconfig ) = @_;
  988. # connect to database
  989. my $dbh = DBI->connect( $myconfig->{dbconnect},
  990. $myconfig->{dbuser}, $myconfig->{dbpasswd} )
  991. or $self->dberror;
  992. $dbh->{pg_enable_utf8} = 1;
  993. # set db options
  994. if ( $myconfig->{dboptions} ) {
  995. $dbh->do( $myconfig->{dboptions} )
  996. || $self->dberror( $myconfig->{dboptions} );
  997. }
  998. $dbh;
  999. }
  1000. =item $form->dbconnect_noauto($myconfig);
  1001. Returns a non-autocommit connection to the database specified in $myconfig.
  1002. =cut
  1003. sub dbconnect_noauto {
  1004. my ( $self, $myconfig ) = @_;
  1005. # connect to database
  1006. my $dbh = DBI->connect(
  1007. $myconfig->{dbconnect}, $myconfig->{dbuser},
  1008. $myconfig->{dbpasswd}, { AutoCommit => 0 }
  1009. ) or $self->dberror;
  1010. $dbh->{pg_enable_utf8} = 1;
  1011. # set db options
  1012. if ( $myconfig->{dboptions} ) {
  1013. $dbh->do( $myconfig->{dboptions} );
  1014. }
  1015. $dbh;
  1016. }
  1017. =item $form->dbquote($var);
  1018. If $var is an empty string, return NULL, otherwise return $var as quoted by
  1019. $form->{dbh}->quote($var).
  1020. =cut
  1021. sub dbquote {
  1022. my ( $self, $var ) = @_;
  1023. if ( $var eq '' ) {
  1024. $_ = "NULL";
  1025. }
  1026. else {
  1027. $_ = $self->{dbh}->quote($var);
  1028. }
  1029. $_;
  1030. }
  1031. =item $form->update_balance($dbh, $table, $field, $where, $value);
  1032. B<WARNING>: This is a dangerous private function. All apps calling it must be
  1033. careful to avoid SQL injection issues.
  1034. If $value is set, sets the value of $field in $table to the sum of the current
  1035. stored value and $value. In order to not annihilate the values in $table,
  1036. $where must contain a WHERE clause that limits the UPDATE to a single row.
  1037. =cut
  1038. sub update_balance {
  1039. # This is a dangerous private function. All apps calling it must
  1040. # be careful to avoid SQL injection issues
  1041. my ( $self, $dbh, $table, $field, $where, $value ) = @_;
  1042. $table = $dbh->quote_identifier($table);
  1043. $field = $dbh->quote_identifier($field);
  1044. # if we have a value, go do it
  1045. if ($value) {
  1046. # retrieve balance from table
  1047. my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
  1048. my ($balance) = $dbh->selectrow_array($query);
  1049. $balance = $dbh->quote($balance + $value);
  1050. # update balance
  1051. $query = "UPDATE $table SET $field = $balance WHERE $where";
  1052. $dbh->do($query) || $self->dberror($query);
  1053. }
  1054. }
  1055. =item $form->update_exchangerate($dbh, $curr, $transdate, $buy, $sell);
  1056. Updates the exchange rates $buy and $sell for the given $currency on $transdate.
  1057. If there is not yet an exchange rate for $currency on $transdate, an entry is
  1058. inserted. This returns without doing anything if $curr eq ''.
  1059. $dbh is not used, favouring $self->{dbh}.
  1060. =cut
  1061. sub update_exchangerate {
  1062. my ( $self, $dbh, $curr, $transdate, $buy, $sell ) = @_;
  1063. # some sanity check for currency
  1064. return if ( $curr eq "" );
  1065. my $query = qq|
  1066. SELECT curr
  1067. FROM exchangerate
  1068. WHERE curr = ?
  1069. AND transdate = ?
  1070. FOR UPDATE|;
  1071. my $sth = $self->{dbh}->prepare($query);
  1072. $sth->execute( $curr, $transdate ) || $self->dberror($query);
  1073. my $set;
  1074. my @queryargs;
  1075. if ( $buy && $sell ) {
  1076. $set = "buy = ?, sell = ?";
  1077. @queryargs = ( $buy, $sell );
  1078. }
  1079. elsif ($buy) {
  1080. $set = "buy = ?";
  1081. @queryargs = ($buy);
  1082. }
  1083. elsif ($sell) {
  1084. $set = "sell = ?";
  1085. @queryargs = ($sell);
  1086. }
  1087. if ( !$set ) {
  1088. $self->error("Exchange rate missing!");
  1089. }
  1090. if ( $sth->fetchrow_array ) {
  1091. $query = qq|UPDATE exchangerate
  1092. SET $set
  1093. WHERE curr = ?
  1094. AND transdate = ?|;
  1095. push( @queryargs, $curr, $transdate );
  1096. }
  1097. else {
  1098. $query = qq|
  1099. INSERT INTO exchangerate (
  1100. curr, buy, sell, transdate)
  1101. VALUES (?, ?, ?, ?)|;
  1102. @queryargs = ( $curr, $buy, $sell, $transdate );
  1103. }
  1104. $sth->finish;
  1105. $sth = $self->{dbh}->prepare($query);
  1106. $sth->execute(@queryargs) || $self->dberror($query);
  1107. }
  1108. =item $form->save_exchangerate($myconfig, $currency, $transdate, $rate, $fld);
  1109. Saves the exchange rate $rate for the given $currency on $transdate for the
  1110. provided purpose in $fld. $fld can be either 'buy' or 'sell'.
  1111. $myconfig is not used. $self->update_exchangerate is used for the majority of
  1112. the work.
  1113. =cut
  1114. sub save_exchangerate {
  1115. my ( $self, $myconfig, $currency, $transdate, $rate, $fld ) = @_;
  1116. my ( $buy, $sell ) = ( 0, 0 );
  1117. $buy = $rate if $fld eq 'buy';
  1118. $sell = $rate if $fld eq 'sell';
  1119. $self->update_exchangerate( $self->{dbh}, $currency, $transdate, $buy,
  1120. $sell );
  1121. }
  1122. =item $form->get_exchangerate($dbh, $curr, $transdate, $fld);
  1123. Returns the exchange rate in relation to the default currency for $currency on
  1124. $transdate for the purpose indicated by $fld. $fld can be either 'buy' or
  1125. 'sell' to get usable results.
  1126. $dbh is not used, favouring $self->{dbh}.
  1127. =cut
  1128. sub get_exchangerate {
  1129. my ( $self, $dbh, $curr, $transdate, $fld ) = @_;
  1130. my $exchangerate = 1;
  1131. if ($transdate) {
  1132. my $query = qq|
  1133. SELECT $fld FROM exchangerate
  1134. WHERE curr = ? AND transdate = ?|;
  1135. my $sth = $self->{dbh}->prepare($query);
  1136. $sth->execute( $curr, $transdate );
  1137. ($exchangerate) = $sth->fetchrow_array;
  1138. $exchangerate = Math::BigFloat->new($exchangerate);
  1139. $sth->finish;
  1140. }
  1141. $exchangerate;
  1142. }
  1143. =item $form->check_exchangerate($myconfig, $currency, $transdate, $fld);
  1144. Returns some true value when an entry for $currency on $transdate is true for
  1145. the purpose indicated by $fld. $fld can be either 'buy' or 'sell' to get
  1146. usable results. Returns false if $transdate is not set.
  1147. $myconfig is not used.
  1148. =cut
  1149. sub check_exchangerate {
  1150. my ( $self, $myconfig, $currency, $transdate, $fld ) = @_;
  1151. return "" unless $transdate;
  1152. my $query = qq|
  1153. SELECT $fld
  1154. FROM exchangerate
  1155. WHERE curr = ? AND transdate = ?|;
  1156. my $sth = $self->{dbh}->prepare($query);
  1157. $sth->execute( $currency, $transdate );
  1158. my @array = $sth->fetchrow_array;
  1159. $self->db_parse_numeric(sth => $sth, arrayref => \@array);
  1160. my ($exchangerate) = @array;
  1161. $sth->finish;
  1162. $exchangerate;
  1163. }
  1164. =item $form->add_shipto($dbh, $id);
  1165. Inserts a new address into the table shipto if the value of any of the shipto
  1166. address components in $form differs to the regular attribute in $form. The
  1167. inserted value of trans_id is $id, the other fields correspond with the shipto
  1168. address components of $form.
  1169. $dbh is unused.
  1170. =cut
  1171. sub add_shipto {
  1172. my ( $self, $dbh, $id ) = @_;
  1173. my $shipto;
  1174. foreach my $item (
  1175. qw(name address1 address2 city state
  1176. zipcode country contact phone fax email)
  1177. )
  1178. {
  1179. if ( $self->{"shipto$item"} ne "" ) {
  1180. $shipto = 1 if ( $self->{$item} ne $self->{"shipto$item"} );
  1181. }
  1182. }
  1183. if ($shipto) {
  1184. my $query = qq|
  1185. INSERT INTO shipto
  1186. (trans_id, shiptoname, shiptoaddress1,
  1187. shiptoaddress2, shiptocity, shiptostate,
  1188. shiptozipcode, shiptocountry, shiptocontact,
  1189. shiptophone, shiptofax, shiptoemail)
  1190. VALUES ( ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)
  1191. |;
  1192. my $sth = $self->{dbh}->prepare($query) || $self->dberror($query);
  1193. $sth->execute(
  1194. $id, $self->{shiptoname},
  1195. $self->{shiptoaddress1}, $self->{shiptoaddress2},
  1196. $self->{shiptocity}, $self->{shiptostate},
  1197. $self->{shiptozipcode}, $self->{shiptocountry},
  1198. $self->{shiptocontact}, $self->{shiptophone},
  1199. $self->{shiptofax}, $self->{shiptoemail}
  1200. ) || $self->dberror($query);
  1201. $sth->finish;
  1202. }
  1203. }
  1204. =item $form->get_employee($dbh);
  1205. Returns a list containing the name and id of the employee $form->{login}. Any
  1206. portion of $form->{login} including and past '@' are ignored.
  1207. $dbh is unused.
  1208. =cut
  1209. sub get_employee {
  1210. my ( $self, $dbh ) = @_;
  1211. my $login = $self->{login};
  1212. $login =~ s/@.*//;
  1213. my $query = qq|
  1214. SELECT name, id
  1215. FROM entity WHERE id IN (select entity_id
  1216. FROM users
  1217. WHERE username = ?)|;
  1218. my $sth = $self->{dbh}->prepare($query);
  1219. $sth->execute($login);
  1220. my (@a) = $sth->fetchrow_array();
  1221. $a[1] *= 1;
  1222. $sth->finish;
  1223. @a;
  1224. }
  1225. =item $form->get_name($myconfig, $table[, $transdate])
  1226. Sets $form->{name_list} to refer to a list of customers or vendors whose names
  1227. or numbers match the value found in $form->{$table} and returns the number of
  1228. matches. $table can be 'vendor', 'customer', or 'employee'; if the optional
  1229. field $transdate is provided, the result set is further limited to $table
  1230. entries which were active on the provided date as determined by the start and
  1231. end dates. The elements of $form->{name_list} are references returned rows in
  1232. hashref form and are sorted by the name field. The fields of the hash are those
  1233. of the view $table and the table entity.
  1234. $myconfig is unused.
  1235. =cut
  1236. # this sub gets the id and name from $table
  1237. sub get_name {
  1238. my ( $self, $myconfig, $table, $transdate ) = @_;
  1239. my @queryargs;
  1240. my $where;
  1241. if ($transdate) {
  1242. $where = qq|
  1243. AND (c.startdate IS NULL OR c.startdate <= ?)
  1244. AND (c.enddate IS NULL OR c.enddate >= ?)|;
  1245. @queryargs = ( $transdate, $transdate );
  1246. }
  1247. # SC: Check for valid table/view name. Other values will cause SQL errors.
  1248. if ($table !~ /^(vendor|customer|employee)$/i) {
  1249. $self->error('Invalid name source');
  1250. }
  1251. # Company name is stored in $self->{vendor} or $self->{customer}
  1252. if ($self->{"${table}number"} eq ''){
  1253. $self->{"${table}number"} = $self->{$table};
  1254. }
  1255. my $name = $self->like( lc $self->{$table} );
  1256. # Vendor and Customer are now views into entity_credit_account.
  1257. my $query = qq/
  1258. SELECT c.*, e.name FROM entity_credit_account c
  1259. JOIN entity e ON (c.entity_id = e.id)
  1260. WHERE (lower(e.name) LIKE ?
  1261. OR c.meta_number LIKE ?)
  1262. $where
  1263. ORDER BY e.name/;
  1264. unshift( @queryargs, $name, $self->{"${table}number"} );
  1265. my $sth = $self->{dbh}->prepare($query);
  1266. $sth->execute(@queryargs) || $self->dberror($query);
  1267. my $i = 0;
  1268. @{ $self->{name_list} } = ();
  1269. while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  1270. push( @{ $self->{name_list} }, $ref );
  1271. $i++;
  1272. }
  1273. $sth->finish;
  1274. return $i;
  1275. }
  1276. =item $form->all_vc($myconfig, $vc, $module, $dbh, $transdate, $job);
  1277. Populates the list referred to by $form->{all_${vc}} with hashes of either
  1278. vendor or customer id and name, ordered by the name. This will be vendor
  1279. details unless $vc is set to 'customer'. This list can be limited to only
  1280. vendors or customers which are usable on a given day by specifying $transdate.
  1281. As a further restriction, $form->{all_${vc}} will not be populated if the
  1282. number of vendors or customers that would be present in that list exceeds, or
  1283. is equal to, $myconfig->{vclimit}.
  1284. In addition to the possible population of $form->{all_${vc}},
  1285. $form->{employee_id} is looked up if not already set, the list
  1286. $form->{all_language} is populated using the language table and is sorted by the
  1287. description, and $form->all_employees, $form->all_departments,
  1288. $form->all_projects, and $form->all_taxaccounts are all run.
  1289. $module and $dbh are unused.
  1290. =cut
  1291. sub all_vc {
  1292. my ( $self, $myconfig, $vc, $module, $dbh, $transdate, $job ) = @_;
  1293. my $ref;
  1294. my $table;
  1295. if ($module eq 'AR'){
  1296. $table = 'ar';
  1297. } elsif ($module eq 'AP'){
  1298. $table = 'ap';
  1299. }
  1300. $dbh = $self->{dbh};
  1301. my $sth;
  1302. if ($vc eq 'customer'){
  1303. $self->{vc_class} = 1;
  1304. } else {
  1305. $self->{vc_class} = 2;
  1306. $vc = 'vendor';
  1307. }
  1308. my $query = qq|SELECT count(*) FROM entity_credit_account ec
  1309. where ec.entity_class = ?|;
  1310. my $where;
  1311. my @queryargs2 = ($self->{vc_class});
  1312. my @queryargs;
  1313. if ($transdate) {
  1314. $query .= qq| AND (ec.startdate IS NULL OR ec.startdate <= ?)
  1315. AND (ec.enddate IS NULL OR ec.enddate >= ?)|;
  1316. $where = qq| (ec.startdate IS NULL OR ec.startdate <= ?)
  1317. AND (ec.enddate IS NULL OR ec.enddate >= ?)
  1318. AND ec.entity_class = ?|;
  1319. push (@queryargs, $transdate, $transdate, $self->{vc_class});
  1320. push (@queryargs2, $transdate, $transdate);
  1321. } else {
  1322. $where = " true";
  1323. }
  1324. $sth = $dbh->prepare($query);
  1325. $sth->execute(@queryargs2);
  1326. my ($count) = $sth->fetchrow_array;
  1327. $sth->finish;
  1328. # build selection list
  1329. if ( $count < $myconfig->{vclimit} ) {
  1330. $self->{"${vc}_id"} *= 1;
  1331. # TODO: Alter this so that it pulls up the entity_credit_account
  1332. # instead of the entity_id. --CT
  1333. $query = qq|
  1334. SELECT ec.id, e.name
  1335. FROM entity e
  1336. JOIN entity_credit_account ec ON (ec.entity_id = e.id)
  1337. WHERE ec.id = ? OR $where
  1338. ORDER BY name|;
  1339. push( @queryargs, $self->{"${vc}_id"} );
  1340. $sth = $dbh->prepare($query);
  1341. $sth->execute(@queryargs) || $self->dberror($query);
  1342. @{ $self->{"all_$vc"} } = ();
  1343. while ( $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  1344. push @{ $self->{"all_$vc"} }, $ref;
  1345. }
  1346. $sth->finish;
  1347. } elsif ($self->{id}) {
  1348. $query = qq|
  1349. SELECT ec.id, e.name
  1350. FROM entity e
  1351. JOIN entity_credit_account ec ON (ec.entity_id = e.id)
  1352. WHERE ec.id = (select entity_credit_account FROM $table
  1353. WHERE id = ?)
  1354. ORDER BY name|;
  1355. $sth = $self->{dbh}->prepare($query);
  1356. $sth->execute($self->{id});
  1357. ($self->{"${vc}_id"}, $self->{$vc}) = $sth->fetchrow_array();
  1358. }
  1359. # get self
  1360. if ( !$self->{employee_id} ) {
  1361. ( $self->{employee}, $self->{employee_id} ) = split /--/,
  1362. $self->{employee};
  1363. ( $self->{employee}, $self->{employee_id} ) = $self->get_employee($dbh)
  1364. unless $self->{employee_id};
  1365. }
  1366. $self->all_employees( $myconfig, $dbh, $transdate, 1 );
  1367. $self->all_departments( $myconfig, $dbh, $vc );
  1368. $self->all_projects( $myconfig, $dbh, $transdate, $job );
  1369. # get language codes
  1370. $query = qq|SELECT *
  1371. FROM language
  1372. ORDER BY 2|;
  1373. $sth = $dbh->prepare($query);
  1374. $sth->execute || $self->dberror($query);
  1375. $self->{all_language} = ();
  1376. while ( $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  1377. push @{ $self->{all_language} }, $ref;
  1378. }
  1379. $sth->finish;
  1380. $self->all_taxaccounts( $myconfig, $dbh, $transdate );
  1381. }
  1382. =item $form->all_accounts()
  1383. Sets $form->{accounts} to all accounts. Returns the list as well.
  1384. Example: my @account_list = $form->all_accounts();
  1385. =cut
  1386. sub all_accounts {
  1387. my ($self) = @_;
  1388. my $ref;
  1389. $self->{all_accounts} = [];
  1390. my $sth = $self->{dbh}->prepare('SELECT * FROM chart_list_all()');
  1391. $sth->execute || $self->dberror('SELECT * FROM chart_list_all()');
  1392. while ($ref = $sth->fetchrow_hashref('NAME_lc')){
  1393. push(@{$self->{all_accounts}}, $ref);
  1394. }
  1395. $sth->finish;
  1396. return @{$self->{all_accounts}};
  1397. }
  1398. =item $form->all_taxaccounts($myconfig, $dbh2[, $transdate]);
  1399. Get the tax rates and numbers for all the taxes in $form->{taxaccounts}. Does
  1400. nothing if $form->{taxaccounts} is false. Taxes are listed as a space seperated
  1401. list of account numbers from the chart. The retrieved values are placed within
  1402. $form->{${accno}_rate} and $form->{${accno}_taxnumber}. If $transdate is set,
  1403. then only process taxes that were valid on $transdate.
  1404. $myconfig and $dbh2 are unused.
  1405. =cut
  1406. sub all_taxaccounts {
  1407. my ( $self, $myconfig, $dbh2, $transdate ) = @_;
  1408. my $dbh = $self->{dbh};
  1409. my $sth;
  1410. my $query;
  1411. my $where;
  1412. my @queryargs = ();
  1413. if ($transdate) {
  1414. $where = qq| AND (t.validto >= ? OR t.validto IS NULL)|;
  1415. push( @queryargs, $transdate );
  1416. }
  1417. if ( $self->{taxaccounts} ) {
  1418. # rebuild tax rates
  1419. $query = qq|SELECT t.rate, t.taxnumber
  1420. FROM tax t
  1421. JOIN chart c ON (c.id = t.chart_id)
  1422. WHERE c.accno = ?
  1423. $where
  1424. ORDER BY accno, validto|;
  1425. $sth = $dbh->prepare($query) || $self->dberror($query);
  1426. foreach my $accno ( split / /, $self->{taxaccounts} ) {
  1427. $sth->execute( $accno, @queryargs );
  1428. ( $self->{"${accno}_rate"}, $self->{"${accno}_taxnumber"} ) =
  1429. $sth->fetchrow_array;
  1430. $sth->finish;
  1431. }
  1432. }
  1433. }
  1434. =item $form->all_employees($myconfig, $dbh2, $transdate, $sales);
  1435. Sets $form->{all_employee} to be a reference to an array referencing hashes of
  1436. employee information. The hashes are of the form {'id' => id, 'name' => name}.
  1437. If $transdate is set, the query is limited to employees who are active on that
  1438. day. If $sales is true, only employees with the sales flag set are added.
  1439. $dbh2 is unused.
  1440. =cut
  1441. sub all_employees {
  1442. my ( $self, $myconfig, $dbh2, $transdate, $sales ) = @_;
  1443. my $dbh = $self->{dbh};
  1444. my @whereargs = ();
  1445. # setup employees/sales contacts
  1446. my $query = qq|
  1447. SELECT id, name
  1448. FROM entity
  1449. WHERE id IN (SELECT entity_id FROM employee
  1450. WHERE|;
  1451. if ($transdate) {
  1452. $query .= qq| (startdate IS NULL OR startdate <= ?)
  1453. AND (enddate IS NULL OR enddate >= ?) AND|;
  1454. @whereargs = ( $transdate, $transdate );
  1455. }
  1456. else {
  1457. $query .= qq| enddate IS NULL AND|;
  1458. }
  1459. if ($sales) {
  1460. $query .= qq| sales = '1' AND|;
  1461. }
  1462. $query =~ s/(WHERE|AND)$//;
  1463. $query .= qq|) ORDER BY name|;
  1464. my $sth = $dbh->prepare($query);
  1465. $sth->execute(@whereargs) || $self->dberror($query);
  1466. while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  1467. push @{ $self->{all_employee} }, $ref;
  1468. }
  1469. $sth->finish;
  1470. }
  1471. =item $form->all_projects($myconfig, $dbh2[, $transdate, $job]);
  1472. Populates the list referred to as $form->{all_project} with hashes detailing
  1473. all projects. If $job is true, limit the projects to those whose ids are not
  1474. also present in parts with a project_id > 0. If $transdate is set, the projects
  1475. are limited to those valid on $transdate. If $form->{language_code} is set,
  1476. include the translation description in the project list and limit to
  1477. translations with a matching language_code. The result list,
  1478. $form->{all_project}, is sorted by projectnumber.
  1479. $myconfig and $dbh2 are unused. $job appears to be part of attempted job-
  1480. costing support.
  1481. =cut
  1482. sub all_projects {
  1483. my ( $self, $myconfig, $dbh2, $transdate, $job ) = @_;
  1484. my $dbh = $self->{dbh};
  1485. my @queryargs = ();
  1486. my $where = "1 = 1";
  1487. $where = qq|id NOT IN (SELECT id
  1488. FROM parts
  1489. WHERE project_id > 0)| if !$job;
  1490. my $query = qq|SELECT *
  1491. FROM project
  1492. WHERE $where|;
  1493. if ( $self->{language_code} ) {
  1494. $query = qq|
  1495. SELECT pr.*, t.description AS translation
  1496. FROM project pr
  1497. LEFT JOIN translation t ON (t.trans_id = pr.id)
  1498. WHERE t.language_code = ?|;
  1499. push( @queryargs, $self->{language_code} );
  1500. }
  1501. if ($transdate) {
  1502. $query .= qq| AND (startdate IS NULL OR startdate <= ?)
  1503. AND (enddate IS NULL OR enddate >= ?)|;
  1504. push( @queryargs, $transdate, $transdate );
  1505. }
  1506. $query .= qq| ORDER BY projectnumber|;
  1507. my $sth = $dbh->prepare($query);
  1508. $sth->execute(@queryargs) || $self->dberror($query);
  1509. @{ $self->{all_project} } = ();
  1510. while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  1511. push @{ $self->{all_project} }, $ref;
  1512. }
  1513. $sth->finish;
  1514. }
  1515. =item $form->all_departments($myconfig, $dbh2, $vc);
  1516. Set $form->{all_department} to be a reference to a list of hashrefs describing
  1517. departments of the form {'id' => id, 'description' => description}. If $vc
  1518. is 'customer', further limit the results to those whose role is 'P' (Profit
  1519. Center).
  1520. This procedure is internally followed by a call to $form->all_years($myconfig).
  1521. $dbh2 is not used.
  1522. =cut
  1523. sub all_departments {
  1524. my ( $self, $myconfig, $dbh2, $vc ) = @_;
  1525. my $dbh = $self->{dbh};
  1526. my $where = "1 = 1";
  1527. if ($vc) {
  1528. if ( $vc eq 'customer' ) {
  1529. $where = " role = 'P'";
  1530. }
  1531. }
  1532. my $query = qq|SELECT id, description
  1533. FROM department
  1534. WHERE $where
  1535. ORDER BY 2|;
  1536. my $sth = $dbh->prepare($query);
  1537. $sth->execute || $self->dberror($query);
  1538. @{ $self->{all_department} } = ();
  1539. while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  1540. push @{ $self->{all_department} }, $ref;
  1541. }
  1542. $sth->finish;
  1543. $self->all_years($myconfig);
  1544. }
  1545. =item $form->all_languages($myconfig);
  1546. Set $form->{all_language} to be a reference to a list of hashrefs describing
  1547. languages using the form {'code' => code, 'description' => description}.
  1548. =cut
  1549. sub all_languages {
  1550. my ( $self ) = @_;
  1551. my $dbh = $self->{dbh};
  1552. my $query = qq|
  1553. SELECT code, description
  1554. FROM language
  1555. ORDER BY description|;
  1556. my $sth = $dbh->prepare($query);
  1557. $sth->execute || $self->dberror($query);
  1558. $self->{all_language} = [];
  1559. while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  1560. push @{ $self->{all_language} }, $ref;
  1561. }
  1562. $sth->finish;
  1563. }
  1564. =item $form->all_years($myconfig[, $dbh2]);
  1565. Populates the hash $form->{all_month} with a mapping between a two-digit month
  1566. number and the English month name. Populates the list $form->{all_years} with
  1567. all years which contain transactions.
  1568. $dbh2 is unused.
  1569. =cut
  1570. sub all_years {
  1571. my ( $self, $myconfig ) = @_;
  1572. my $dbh = $self->{dbh};
  1573. $self->{all_years} = [];
  1574. # get years
  1575. my $query = qq|
  1576. SELECT extract('YEARS' FROM transdate) FROM acc_trans
  1577. GROUP BY extract('YEARS' FROM transdate) ORDER BY 1 DESC|;
  1578. my $sth = $dbh->prepare($query);
  1579. $sth->execute();
  1580. while (my ($year) = $sth->fetchrow_array()){
  1581. push @{$self->{all_years}}, $year;
  1582. }
  1583. #this should probably be changed to use locale
  1584. %{ $self->{all_month} } = (
  1585. '01' => 'January',
  1586. '02' => 'February',
  1587. '03' => 'March',
  1588. '04' => 'April',
  1589. '05' => 'May ',
  1590. '06' => 'June',
  1591. '07' => 'July',
  1592. '08' => 'August',
  1593. '09' => 'September',
  1594. '10' => 'October',
  1595. '11' => 'November',
  1596. '12' => 'December'
  1597. );
  1598. }
  1599. =item $form->create_links($module, $myconfig, $vc[, $job]);
  1600. Populates the hash referred to as $form->{${module}_links} details about
  1601. accounts that have $module in their link field. The hash is keyed upon link
  1602. elements such as 'AP_amount' and 'AR_tax' and they refer to lists of hashes
  1603. containing accno and description for the appropriate accounts. If the key does
  1604. not contain 'tax', the account number is appended to the space seperated list
  1605. $form->{accounts}. $module is typically 'AR' or 'AP' and is the base type of
  1606. the accounts looked up.
  1607. If $form->{id} is not set, check $form->{"$form->{vc}_id"}. If neither is set,
  1608. use $form->lastname_used to populate the details. If $form->{id} is set,
  1609. populate the invnumber, transdate, ${vc}_id, datepaid, duedate, ordnumber,
  1610. taxincluded, currency, notes, intnotes, ${vc}, department_id, department,
  1611. oldinvtotal, oldtotalpaid, employee_id, employee, language_code, ponumber,
  1612. reverse, printed, emailed, queued, recurring, exchangerate, and acc_trans
  1613. attributes of $form with details about the transaction $form->{id}. All of
  1614. these attributes, save for acc_trans, are scalar; $form->{acc_trans} refers to
  1615. a hash keyed by link elements whose values are lists of references to hashes
  1616. describing acc_trans table entries corresponding to the transaction $form->{id}.
  1617. The elements in the acc_trans entry hashes are accno, description, source,
  1618. amount, memo, transdate, cleared, project_id, projectnumber, and exchangerate.
  1619. The closedto, separate_duties, revtrans, and currencies $form attributes are filled with values
  1620. from the defaults table, while $form->{current_date} is populated with the
  1621. current date. If $form->{id} is not set, then $form->{transdate} also takes on
  1622. the current date.
  1623. After all this, it calls $form->all_vc to conclude.
  1624. =cut
  1625. sub create_links {
  1626. my ( $self, $module, $myconfig, $vc, $job ) = @_;
  1627. # get last customers or vendors
  1628. my ( $query, $sth );
  1629. if (!$self->{dbh}) {
  1630. $self->db_init($myconfig);
  1631. }
  1632. my $dbh = $self->{dbh};
  1633. my %xkeyref = ();
  1634. my $val;
  1635. my $ref;
  1636. my $key;
  1637. # now get the account numbers
  1638. $query = qq|SELECT accno, description, link
  1639. FROM chart
  1640. WHERE link LIKE ?
  1641. ORDER BY accno|;
  1642. $sth = $dbh->prepare($query);
  1643. $sth->execute( "%" . "$module%" ) || $self->dberror($query);
  1644. $self->{accounts} = "";
  1645. while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  1646. foreach my $key ( split /:/, $ref->{link} ) {
  1647. if ( $key =~ /$module/ ) {
  1648. # cross reference for keys
  1649. $xkeyref{ $ref->{accno} } = $key;
  1650. push @{ $self->{"${module}_links"}{$key} },
  1651. {
  1652. accno => $ref->{accno},
  1653. description => $ref->{description}
  1654. };
  1655. $self->{accounts} .= "$ref->{accno} "
  1656. unless $key =~ /tax/;
  1657. }
  1658. }
  1659. }
  1660. $sth->finish;
  1661. my $arap = ( $vc eq 'customer' ) ? 'ar' : 'ap';
  1662. $vc = 'vendor' unless $vc eq 'customer';
  1663. if ( $self->{id} ) {
  1664. $query = qq|
  1665. SELECT a.invnumber, a.transdate,
  1666. a.entity_credit_account AS entity_id,
  1667. a.datepaid, a.duedate, a.ordnumber,
  1668. a.taxincluded, a.curr AS currency, a.notes,
  1669. a.intnotes, ce.name AS $vc, a.department_id,
  1670. d.description AS department,
  1671. a.amount AS oldinvtotal, a.paid AS oldtotalpaid,
  1672. a.person_id, e.name AS employee,
  1673. c.language_code, a.ponumber, a.reverse,
  1674. a.approved
  1675. FROM $arap a
  1676. JOIN entity_credit_account c
  1677. ON (a.entity_credit_account = c.id)
  1678. JOIN entity ce ON (ce.id = c.entity_id)
  1679. LEFT JOIN employee er ON (er.entity_id = a.person_id)
  1680. LEFT JOIN entity e ON (er.entity_id = e.id)
  1681. LEFT JOIN department d ON (d.id = a.department_id)
  1682. WHERE a.id = ? AND c.entity_class =
  1683. (select id FROM entity_class
  1684. WHERE class ilike ?)|;
  1685. $sth = $dbh->prepare($query);
  1686. $sth->execute( $self->{id}, $self->{vc} ) || $self->dberror($query);
  1687. $ref = $sth->fetchrow_hashref('NAME_lc');
  1688. $self->db_parse_numeric(sth=>$sth, hashref=>$ref);
  1689. if (!defined $ref->{approved}){
  1690. $ref->{approved} = 0;
  1691. }
  1692. foreach $key ( keys %$ref ) {
  1693. $self->{$key} = $ref->{$key};
  1694. }
  1695. $sth->finish;
  1696. # get printed, emailed
  1697. $query = qq|
  1698. SELECT s.printed, s.emailed, s.spoolfile, s.formname
  1699. FROM status s WHERE s.trans_id = ?|;
  1700. $sth = $dbh->prepare($query);
  1701. $sth->execute( $self->{id} ) || $self->dberror($query);
  1702. while ( $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  1703. $self->{printed} .= "$ref->{formname} "
  1704. if $ref->{printed};
  1705. $self->{emailed} .= "$ref->{formname} "
  1706. if $ref->{emailed};
  1707. $self->{queued} .= "$ref->{formname} " . "$ref->{spoolfile} "
  1708. if $ref->{spoolfile};
  1709. }
  1710. $sth->finish;
  1711. for (qw(printed emailed queued)) { $self->{$_} =~ s/ +$//g }
  1712. # get recurring
  1713. $self->get_recurring($dbh);
  1714. # get amounts from individual entries
  1715. $query = qq|
  1716. SELECT c.accno, c.description, a.source, a.amount,
  1717. a.memo, a.transdate, a.cleared, a.project_id,
  1718. p.projectnumber
  1719. FROM acc_trans a
  1720. JOIN chart c ON (c.id = a.chart_id)
  1721. LEFT JOIN project p ON (p.id = a.project_id)
  1722. WHERE a.trans_id = ?
  1723. AND a.fx_transaction = '0'
  1724. ORDER BY transdate|;
  1725. $sth = $dbh->prepare($query);
  1726. $sth->execute( $self->{id} ) || $self->dberror($query);
  1727. my $fld = ( $vc eq 'customer' ) ? 'buy' : 'sell';
  1728. $self->{exchangerate} =
  1729. $self->get_exchangerate( $dbh, $self->{currency}, $self->{transdate},
  1730. $fld );
  1731. # store amounts in {acc_trans}{$key} for multiple accounts
  1732. while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  1733. $ref->{exchangerate} =
  1734. $self->get_exchangerate( $dbh, $self->{currency},
  1735. $ref->{transdate}, $fld );
  1736. if ($self->{reverse}){
  1737. $ref->{amount} *= -1;
  1738. }
  1739. push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
  1740. }
  1741. $sth->finish;
  1742. }
  1743. else {
  1744. if ( !$self->{"$self->{vc}_id"} ) {
  1745. $self->lastname_used( $myconfig, $dbh, $vc, $module );
  1746. }
  1747. }
  1748. for (qw(separate_duties current_date curr closedto revtrans)) {
  1749. if ($_ eq 'closedto'){
  1750. $query = qq|
  1751. SELECT value::date FROM defaults
  1752. WHERE setting_key = '$_'|;
  1753. } elsif ($_ eq 'current_date') {
  1754. $query = qq| select $_|;
  1755. } else {
  1756. $query = qq|
  1757. SELECT value FROM defaults
  1758. WHERE setting_key = '$_'|;
  1759. }
  1760. $sth = $dbh->prepare($query);
  1761. $sth->execute || $self->dberror($query);
  1762. ($val) = $sth->fetchrow_array();
  1763. if ( $_ eq 'curr' ) {
  1764. $self->{currencies} = $val;
  1765. }
  1766. else {
  1767. $self->{$_} = $val;
  1768. }
  1769. $sth->finish;
  1770. }
  1771. if (!$self->{id} && !$self->{transdate}){
  1772. $self->{transdate} = $self->{current_date};
  1773. }
  1774. $self->all_vc( $myconfig, $vc, $module, $dbh, $self->{transdate}, $job );
  1775. }
  1776. =item $form->lastname_used($myconfig, $dbh2, $vc, $module);
  1777. Fills the name, currency, ${vc}_id, duedate, and possibly invoice_notes
  1778. attributes of $form with the last used values for the transaction type specified
  1779. by both $vc and $form->{type}. $vc can be either 'vendor' or 'customer' and if
  1780. unspecified will take on the value given in $form->{vc}, defaulting to 'vendor'.
  1781. If $form->{type} matches /_order/, the transaction type used is order, if it
  1782. matches /_quotation/, quotations are looked through. If $form->{type} does not
  1783. match either of the above, then ar or ap transactions are used.
  1784. $myconfig, $dbh2, and $module are unused.
  1785. =cut
  1786. sub lastname_used {
  1787. my ( $self, $myconfig, $dbh2, $vc, $module ) = @_;
  1788. my $dbh = $self->{dbh};
  1789. $vc ||= $self->{vc}; # add default to correct for improper passing
  1790. my $arap;
  1791. my $where;
  1792. if ($vc eq 'customer') {
  1793. $arap = 'ar';
  1794. } else {
  1795. $arap = 'ap';
  1796. $vc = 'vendor';
  1797. }
  1798. my $sth;
  1799. if ( $self->{type} =~ /_order/ ) {
  1800. $arap = 'oe';
  1801. $where = "quotation = '0'";
  1802. }
  1803. if ( $self->{type} =~ /_quotation/ ) {
  1804. $arap = 'oe';
  1805. $where = "quotation = '1'";
  1806. }
  1807. $where = "AND $where " if $where;
  1808. my $inv_notes;
  1809. $inv_notes = "ct.invoice_notes," if $vc eq 'customer';
  1810. my $query = qq|
  1811. SELECT entity.name, ct.curr AS currency, entity_id AS ${vc}_id,
  1812. current_date + ct.terms AS duedate,
  1813. $inv_notes
  1814. ct.curr AS currency
  1815. FROM $vc ct
  1816. JOIN entity ON (ct.entity_id = entity.id)
  1817. WHERE entity.id = (select entity_id from $arap
  1818. where entity_id IS NOT NULL $where
  1819. order by id DESC limit 1)|;
  1820. $sth = $self->{dbh}->prepare($query);
  1821. $sth->execute() || $self->dberror($query);
  1822. my $ref = $sth->fetchrow_hashref('NAME_lc');
  1823. for ( keys %$ref ) { $self->{$_} = $ref->{$_} }
  1824. $sth->finish;
  1825. }
  1826. =item $form->current_date($myconfig[, $thisdate, $days]);
  1827. If $thisdate is false, get the current date from the database.
  1828. If $thisdate is true, get the date $days days from $thisdate in the date
  1829. format specified by $myconfig->{dateformat} from the database.
  1830. =cut
  1831. sub current_date {
  1832. my ( $self, $myconfig, $thisdate, $days ) = @_;
  1833. my $dbh = $self->{dbh};
  1834. my $query;
  1835. my @queryargs;
  1836. $days *= 1;
  1837. if ($thisdate) {
  1838. my $dateformat = $myconfig->{dateformat};
  1839. if ( $myconfig->{dateformat} !~ /^y/ ) {
  1840. my @a = split /\D/, $thisdate;
  1841. $dateformat .= "yy" if ( length $a[2] > 2 );
  1842. }
  1843. if ( $thisdate !~ /\D/ ) {
  1844. $dateformat = 'yyyymmdd';
  1845. }
  1846. $query = qq|SELECT (to_date(?, ?)
  1847. + ?::interval)::date AS thisdate|;
  1848. @queryargs = ( $thisdate, $dateformat, sprintf('%d days', $days) );
  1849. }
  1850. else {
  1851. $query = qq|SELECT current_date AS thisdate|;
  1852. @queryargs = ();
  1853. }
  1854. my $sth = $dbh->prepare($query);
  1855. $sth->execute(@queryargs);
  1856. my ($thisdate) = $sth->fetchrow_array;
  1857. $thisdate;
  1858. }
  1859. =item $form->like($str);
  1860. Returns '%$str%'
  1861. =cut
  1862. sub like {
  1863. my ( $self, $str ) = @_;
  1864. "%$str%";
  1865. }
  1866. =item $form->redo_rows($flds, $new, $count, $numrows);
  1867. $flds refers to a list of field names and $new refers to a list of row detail
  1868. hashes with the elements of $flds as keys as well as runningnumber for an order
  1869. or another multi-row item that normally expresses elements in the form
  1870. $form->{${fieldname}_${index}}.
  1871. For every $field in @{$flds} populates $form->{${field}_$i} with an appropriate
  1872. value from a $new detail hash where $i is an index between 1 and $count. The
  1873. ordering of the details is done in terms of the runningnumber element of the
  1874. row detail hashes in $new.
  1875. All $form attributes with names of the form ${field}_$i where the index $i is
  1876. between $count + 1 and $numrows is deleted.
  1877. =cut
  1878. sub redo_rows {
  1879. my ( $self, $flds, $new, $count, $numrows ) = @_;
  1880. my @ndx = ();
  1881. for ( 1 .. $count ) {
  1882. push @ndx, { num => $new->[ $_ - 1 ]->{runningnumber}, ndx => $_ };
  1883. }
  1884. my $i = 0;
  1885. # fill rows
  1886. foreach my $item ( sort { $a->{num} <=> $b->{num} } @ndx ) {
  1887. $i++;
  1888. my $j = $item->{ndx} - 1;
  1889. for ( @{$flds} ) { $self->{"${_}_$i"} = $new->[$j]->{$_} }
  1890. }
  1891. # delete empty rows
  1892. for $i ( $count + 1 .. $numrows ) {
  1893. for ( @{$flds} ) { delete $self->{"${_}_$i"} }
  1894. }
  1895. }
  1896. =item $form->get_partsgroup($myconfig[, $p]);
  1897. Populates the list referred to as $form->{all_partsgroup}. $p refers to a hash
  1898. that describes which partsgroups to retrieve. $p->{searchitems} can be 'part',
  1899. 'service', 'assembly', 'labor', or 'nolabor' and will limit the groups to those
  1900. that contain the item type described. $p->{searchitems} and $p->{all} conflict.
  1901. If $p->{all} is set and $p->{language_code} is not, all partsgroups are
  1902. retrieved. If $p->{language_code} is set, also include the translation
  1903. description specified by $p->{language_code} for the partsgroup.
  1904. The results in $form->{all_partsgroup} are normally sorted by partsgroup name.
  1905. If a language_code is specified, the results are then sorted by the translated
  1906. description.
  1907. $myconfig is unused.
  1908. =cut
  1909. sub get_partsgroup {
  1910. my ( $self, $myconfig, $p ) = @_;
  1911. my $dbh = $self->{dbh};
  1912. my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
  1913. FROM partsgroup pg
  1914. JOIN parts p ON (p.partsgroup_id = pg.id)|;
  1915. my $where;
  1916. my $sortorder = "partsgroup";
  1917. if ( $p->{searchitems} eq 'part' ) {
  1918. $where = qq| WHERE (p.inventory_accno_id > 0
  1919. AND p.income_accno_id > 0)|;
  1920. } elsif ( $p->{searchitems} eq 'service' ) {
  1921. $where = qq| WHERE p.inventory_accno_id IS NULL|;
  1922. } elsif ( $p->{searchitems} eq 'assembly' ) {
  1923. $where = qq| WHERE p.assembly = '1'|;
  1924. } elsif ( $p->{searchitems} eq 'labor' ) {
  1925. $where =
  1926. qq| WHERE p.inventory_accno_id > 0 AND p.income_accno_id IS NULL|;
  1927. } elsif ( $p->{searchitems} eq 'nolabor' ) {
  1928. $where = qq| WHERE p.income_accno_id > 0|;
  1929. }
  1930. if ( $p->{all} ) {
  1931. $query = qq|SELECT id, partsgroup
  1932. FROM partsgroup|;
  1933. }
  1934. my @queryargs = ();
  1935. if ( $p->{language_code} ) {
  1936. $sortorder = "translation";
  1937. $query = qq|
  1938. SELECT DISTINCT pg.id, pg.partsgroup,
  1939. t.description AS translation
  1940. FROM partsgroup pg
  1941. JOIN parts p ON (p.partsgroup_id = pg.id)
  1942. LEFT JOIN translation t ON (t.trans_id = pg.id
  1943. AND t.language_code = ?)|;
  1944. @queryargs = ( $p->{language_code} );
  1945. }
  1946. $query .= qq| $where ORDER BY $sortorder|;
  1947. my $sth = $dbh->prepare($query);
  1948. $sth->execute(@queryargs) || $self->dberror($query);
  1949. $self->{all_partsgroup} = ();
  1950. while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  1951. push @{ $self->{all_partsgroup} }, $ref;
  1952. }
  1953. $sth->finish;
  1954. }
  1955. =item $form->update_status($myconfig);
  1956. DELETEs all status rows which have a formname of $form->{formname} and a
  1957. trans_id of $form->{id}. INSERTs a new row into status where trans_id is
  1958. $form->{id}, formname is $form->{formname}, printed and emailed are true if
  1959. their respective $form attributes match /$form->{formname}/, and spoolfile is
  1960. the file extracted from the string $form->{queued} or NULL if there is no entry
  1961. for $form->{formname}.
  1962. $myconfig is unused.
  1963. =cut
  1964. sub update_status {
  1965. my ( $self, $myconfig ) = @_;
  1966. # no id return
  1967. return unless $self->{id};
  1968. my $dbh = $self->{dbh};
  1969. my %queued = split / +/, $self->{queued};
  1970. my $spoolfile =
  1971. ( $queued{ $self->{formname} } )
  1972. ? "'$queued{$self->{formname}}'"
  1973. : 'NULL';
  1974. my $query = qq|DELETE FROM status
  1975. WHERE formname = ?
  1976. AND trans_id = ?|;
  1977. my $sth = $dbh->prepare($query);
  1978. $sth->execute( $self->{formname}, $self->{id} ) || $self->dberror($query);
  1979. $sth->finish;
  1980. my $printed = ( $self->{printed} =~ /$self->{formname}/ ) ? "1" : "0";
  1981. my $emailed = ( $self->{emailed} =~ /$self->{formname}/ ) ? "1" : "0";
  1982. $query = qq|
  1983. INSERT INTO status
  1984. (trans_id, printed, emailed, spoolfile, formname)
  1985. VALUES (?, ?, ?, ?, ?)|;
  1986. $sth = $dbh->prepare($query);
  1987. $sth->execute( $self->{id}, $printed, $emailed, $spoolfile,
  1988. $self->{formname} );
  1989. $sth->finish;
  1990. }
  1991. =item $form->save_status();
  1992. Clears out any old status entries for $form->{id} and saves new status entries.
  1993. Queued form names are extracted from $form->{queued}. Printed and emailed form
  1994. names are extracted from $form->{printed} and $form->{emailed}. The queued,
  1995. printed, and emailed fields are space seperated lists.
  1996. =cut
  1997. sub save_status {
  1998. my ($self) = @_;
  1999. my $dbh = $self->{dbh};
  2000. my $formnames = $self->{printed};
  2001. my $emailforms = $self->{emailed};
  2002. my $query = qq|DELETE FROM status
  2003. WHERE trans_id = ?|;
  2004. my $sth = $dbh->prepare($query);
  2005. $sth->execute( $self->{id} );
  2006. $sth->finish;
  2007. my %queued;
  2008. my $formname;
  2009. my $printed;
  2010. my $emailed;
  2011. if ( $self->{queued} ) {
  2012. %queued = split / +/, $self->{queued};
  2013. foreach $formname ( keys %queued ) {
  2014. $printed = ( $self->{printed} =~ /$formname/ ) ? "1" : "0";
  2015. $emailed = ( $self->{emailed} =~ /$formname/ ) ? "1" : "0";
  2016. if ( $queued{$formname} ) {
  2017. $query = qq|
  2018. INSERT INTO status
  2019. (trans_id, printed, emailed,
  2020. spoolfile, formname)
  2021. VALUES (?, ?, ?, ?, ?)|;
  2022. $sth = $dbh->prepare($query);
  2023. $sth->execute( $self->{id}, $printed, $emailed,
  2024. $queued{$formname}, $formname )
  2025. || $self->dberror($query);
  2026. $sth->finish;
  2027. }
  2028. $formnames =~ s/$formname//;
  2029. $emailforms =~ s/$formname//;
  2030. }
  2031. }
  2032. # save printed, emailed info
  2033. $formnames =~ s/^ +//g;
  2034. $emailforms =~ s/^ +//g;
  2035. my %status = ();
  2036. for ( split / +/, $formnames ) { $status{$_}{printed} = 1 }
  2037. for ( split / +/, $emailforms ) { $status{$_}{emailed} = 1 }
  2038. foreach my $formname ( keys %status ) {
  2039. $printed = ( $formnames =~ /$self->{formname}/ ) ? "1" : "0";
  2040. $emailed = ( $emailforms =~ /$self->{formname}/ ) ? "1" : "0";
  2041. $query = qq|
  2042. INSERT INTO status (trans_id, printed, emailed,
  2043. formname)
  2044. VALUES (?, ?, ?, ?)|;
  2045. $sth = $dbh->prepare($query);
  2046. $sth->execute( $self->{id}, $printed, $emailed, $formname );
  2047. $sth->finish;
  2048. }
  2049. $dbh->commit;
  2050. }
  2051. =item $form->get_recurring();
  2052. Sets $form->{recurring} to contain info about the recurrence schedule for the
  2053. action $form->{id}. $form->{recurring} is of the same form used by
  2054. $form->save_recurring($dbh2, $myconfig).
  2055. reference,startdate,repeat,unit,howmany,payment,print,email,message
  2056. text date int text int int text text text
  2057. =cut
  2058. sub get_recurring {
  2059. my ($self) = @_;
  2060. my $dbh = $self->{dbh};
  2061. my $query = qq/
  2062. SELECT s.*, se.formname || ':' || se.format AS emaila,
  2063. se.message, sp.formname || ':' ||
  2064. sp.format || ':' || sp.printer AS printa
  2065. FROM recurring s
  2066. LEFT JOIN recurringemail se ON (s.id = se.id)
  2067. LEFT JOIN recurringprint sp ON (s.id = sp.id)
  2068. WHERE s.id = ?/;
  2069. my $sth = $dbh->prepare($query);
  2070. $sth->execute( $self->{id} ) || $self->dberror($query);
  2071. for (qw(email print)) { $self->{"recurring$_"} = "" }
  2072. while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  2073. for ( keys %$ref ) { $self->{"recurring$_"} = $ref->{$_} }
  2074. $self->{recurringemail} .= "$ref->{emaila}:";
  2075. $self->{recurringprint} .= "$ref->{printa}:";
  2076. for (qw(emaila printa)) { delete $self->{"recurring$_"} }
  2077. }
  2078. $sth->finish;
  2079. chop $self->{recurringemail};
  2080. chop $self->{recurringprint};
  2081. if ( $self->{recurringstartdate} ) {
  2082. $self->{recurringreference} =
  2083. $self->escape( $self->{recurringreference}, 1 );
  2084. $self->{recurringmessage} =
  2085. $self->escape( $self->{recurringmessage}, 1 );
  2086. for (
  2087. qw(reference startdate repeat unit howmany
  2088. payment print email message)
  2089. )
  2090. {
  2091. $self->{recurring} .= qq|$self->{"recurring$_"},|;
  2092. }
  2093. chop $self->{recurring};
  2094. }
  2095. }
  2096. =item $form->save_recurring($dbh2, $myconfig);
  2097. Saves or deletes recurring transaction scheduling. $form->{id} is used to
  2098. determine the id used in the various recurring tables. A recurring transaction
  2099. schedule is deleted by having $form->{recurring} be false. For adding or
  2100. updating a schedule, $form->{recurring} is a comma seperated field with partial
  2101. subfield quoting of the form:
  2102. reference,startdate,repeat,unit,howmany,payment,print,email,message
  2103. text date int text int int text text text
  2104. =over
  2105. =item reference
  2106. A URI-encoded reference string for the recurrence set.
  2107. =item startdate
  2108. The index date for the recurrence.
  2109. =item repeat
  2110. The unitless repetition frequency.
  2111. =item unit
  2112. The interval unit used. Can be 'days', 'weeks', 'months', or 'years',
  2113. capitalisation and pluralisation ignored.
  2114. =item howmany
  2115. The number of recurrences for the transaction.
  2116. =item payment
  2117. Flag to indicate if a payment is included in the transaction.
  2118. =item print
  2119. A colon seperated list of formname:format:printer triplets.
  2120. =item email
  2121. A colon seperated list of formname:format pairs.
  2122. =item message
  2123. A URI-encoded message for the emails to be sent.
  2124. =back
  2125. Values for the nextdate and enddate columns of the recurring table are
  2126. calculated using startdate, repeat, unit, howmany, and the current database
  2127. date. All other fields of the recurring, recurringemail, and recurringprint are
  2128. obtained directly from $form->{recurring}.
  2129. B<WARNING>: This function does not check the validity of most subfields of
  2130. $form->{recurring}.
  2131. $dbh2 is not used.
  2132. =cut
  2133. sub save_recurring {
  2134. my ( $self, $dbh2, $myconfig ) = @_;
  2135. my $dbh = $self->{dbh};
  2136. my $query;
  2137. $query = qq|DELETE FROM recurring
  2138. WHERE id = ?|;
  2139. my $sth = $dbh->prepare($query) || $self->dberror($query);
  2140. $sth->execute( $self->{id} ) || $self->dberror($query);
  2141. $query = qq|DELETE FROM recurringemail
  2142. WHERE id = ?|;
  2143. $sth = $dbh->prepare($query) || $self->dberror($query);
  2144. $sth->execute( $self->{id} ) || $self->dberror($query);
  2145. $query = qq|DELETE FROM recurringprint
  2146. WHERE id = ?|;
  2147. $sth = $dbh->prepare($query) || $self->dberror($query);
  2148. $sth->execute( $self->{id} ) || $self->dberror($query);
  2149. if ( $self->{recurring} ) {
  2150. my %s = ();
  2151. (
  2152. $s{reference}, $s{startdate}, $s{repeat},
  2153. $s{unit}, $s{howmany}, $s{payment},
  2154. $s{print}, $s{email}, $s{message}
  2155. ) = split /,/, $self->{recurring};
  2156. if ($s{unit} !~ /^(day|week|month|year)s?$/i){
  2157. $dbh->rollback;
  2158. $self->error("Invalid recurrence unit");
  2159. }
  2160. if ($s{howmany} == 0){
  2161. $self->error("Cannot set to recur 0 times");
  2162. }
  2163. for (qw(reference message)) { $s{$_} = $self->unescape( $s{$_} ) }
  2164. for (qw(repeat howmany payment)) { $s{$_} *= 1 }
  2165. # calculate enddate
  2166. my $advance = $s{repeat} * ( $s{howmany} - 1 );
  2167. my %interval;
  2168. $interval{'Pg'} =
  2169. "(?::date + interval '$advance $s{unit}')";
  2170. $query = qq|SELECT $interval{$myconfig->{dbdriver}}|;
  2171. my ($enddate) = $dbh->selectrow_array($query, undef, $s{startdate});
  2172. # calculate nextdate
  2173. $query = qq|
  2174. SELECT current_date - ?::date AS a,
  2175. ?::date - current_date AS b|;
  2176. $sth = $dbh->prepare($query) || $self->dberror($query);
  2177. $sth->execute( $s{startdate}, $enddate );
  2178. my ( $a, $b ) = $sth->fetchrow_array;
  2179. if ( $a + $b ) {
  2180. $advance =
  2181. int( ( $a / ( $a + $b ) ) * ( $s{howmany} - 1 ) + 1 ) *
  2182. $s{repeat};
  2183. }
  2184. else {
  2185. $advance = 0;
  2186. }
  2187. my $nextdate = $enddate;
  2188. if ( $advance > 0 ) {
  2189. if ( $advance < ( $s{repeat} * $s{howmany} ) ) {
  2190. $query = qq|SELECT (?::date + interval '$advance $s{unit}')|;
  2191. ($nextdate) = $dbh->selectrow_array($query, undef, $s{startdate});
  2192. }
  2193. }
  2194. else {
  2195. $nextdate = $s{startdate};
  2196. }
  2197. if ( $self->{recurringnextdate} ) {
  2198. $nextdate = $self->{recurringnextdate};
  2199. $query = qq|SELECT ?::date - ?::date|;
  2200. if ( $dbh->selectrow_array($query, undef, $enddate, $nextdate) < 0 ) {
  2201. undef $nextdate;
  2202. }
  2203. }
  2204. $self->{recurringpayment} *= 1;
  2205. $query = qq|
  2206. INSERT INTO recurring
  2207. (id, reference, startdate, enddate, nextdate,
  2208. repeat, unit, howmany, payment)
  2209. VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)|;
  2210. $sth = $dbh->prepare($query);
  2211. $sth->execute(
  2212. $self->{id}, $s{reference}, $s{startdate},
  2213. $enddate, $nextdate, $s{repeat},
  2214. $s{unit}, $s{howmany}, $s{payment}
  2215. );
  2216. my @p;
  2217. my $p;
  2218. my $i;
  2219. my $sth;
  2220. if ( $s{email} ) {
  2221. # formname:format
  2222. @p = split /:/, $s{email};
  2223. $query =
  2224. qq|INSERT INTO recurringemail (id, formname, format, message)
  2225. VALUES (?, ?, ?, ?)|;
  2226. $sth = $dbh->prepare($query) || $self->dberror($query);
  2227. for ( $i = 0 ; $i <= $#p ; $i += 2 ) {
  2228. $sth->execute( $self->{id}, $p[$i], $p[ $i + 1 ], $s{message} );
  2229. }
  2230. $sth->finish;
  2231. }
  2232. if ( $s{print} ) {
  2233. # formname:format:printer
  2234. @p = split /:/, $s{print};
  2235. $query =
  2236. qq|INSERT INTO recurringprint (id, formname, format, printer)
  2237. VALUES (?, ?, ?, ?)|;
  2238. $sth = $dbh->prepare($query) || $self->dberror($query);
  2239. for ( $i = 0 ; $i <= $#p ; $i += 3 ) {
  2240. $p = ( $p[ $i + 2 ] ) ? $p[ $i + 2 ] : "";
  2241. $sth->execute( $self->{id}, $p[$i], $p[ $i + 1 ], $p );
  2242. }
  2243. $sth->finish;
  2244. }
  2245. }
  2246. $dbh->commit;
  2247. }
  2248. =item $form->save_intnotes($myconfig, $vc);
  2249. Sets the intnotes field of the entry in the table $vc that has the id
  2250. $form->{id} to the value of $form->{intnotes}.
  2251. Does nothing if $form->{id} is not set.
  2252. =cut
  2253. sub save_intnotes {
  2254. my ( $self, $myconfig, $vc ) = @_;
  2255. # no id return
  2256. return unless $self->{id};
  2257. my $dbh = $self->{dbh};
  2258. my $query = qq|UPDATE $vc SET intnotes = ? WHERE id = ?|;
  2259. my $sth = $dbh->prepare($query);
  2260. $sth->execute( $self->{intnotes}, $self->{id} ) || $self->dberror($query);
  2261. $dbh->commit;
  2262. }
  2263. =item $form->update_defaults($myconfig, $fld[, $dbh]);
  2264. Updates the defaults entry for the setting $fld following rules specified by
  2265. the existing value and returns the processed value that results. If $form is
  2266. false, such as the case when invoked as "Form::update_defaults('',...)", $dbh is
  2267. used as the handle. When $form is set, it uses $form->{dbh}, initialising the
  2268. connection if it does not yet exist. The entry $fld must exist prior to
  2269. executing this function and this update function does not handle the general
  2270. case of updating the defaults table.
  2271. B<NOTE>: rules handling is currently broken.
  2272. Rules followed by this function's processing:
  2273. =over
  2274. =item *
  2275. If digits are found in the field, increment the left-most set. This change,
  2276. unlike the others is reflected in the UPDATE.
  2277. =item *
  2278. Replace <?lsmb date ?> with the date specified in $form->{transdate} formatted
  2279. as $myconfig->{dateformat}.
  2280. =item *
  2281. Replace <?lsmb curr ?> with the value of $form->{currency}
  2282. =back
  2283. =cut
  2284. sub update_defaults {
  2285. my ( $self, $myconfig, $fld ) = @_;
  2286. if ( !$self->{dbh} && $self ) {
  2287. $self->db_init($myconfig);
  2288. }
  2289. my $dbh = $self->{dbh};
  2290. if ( !$self ) {
  2291. $dbh = $_[3];
  2292. }
  2293. my $query = qq|
  2294. SELECT value FROM defaults
  2295. WHERE setting_key = ? FOR UPDATE|;
  2296. my $sth = $dbh->prepare($query);
  2297. $sth->execute($fld);
  2298. ($_) = $sth->fetchrow_array();
  2299. $_ = "0" unless $_;
  2300. # check for and replace
  2301. # <?lsmb DATE ?>, <?lsmb YYMMDD ?>, <?lsmb YEAR ?>, <?lsmb MONTH ?>, <?lsmb DAY ?> or variations of
  2302. # <?lsmb NAME 1 1 3 ?>, <?lsmb BUSINESS ?>, <?lsmb BUSINESS 10 ?>, <?lsmb CURR... ?>
  2303. # <?lsmb DESCRIPTION 1 1 3 ?>, <?lsmb ITEM 1 1 3 ?>, <?lsmb PARTSGROUP 1 1 3 ?> only for parts
  2304. # <?lsmb PHONE ?> for customer and vendors
  2305. my $num = $_;
  2306. ($num) = $num =~ /(\d+)/;
  2307. if ( defined $num ) {
  2308. my $incnum;
  2309. # if we have leading zeros check how long it is
  2310. if ( $num =~ /^0/ ) {
  2311. my $l = length $num;
  2312. $incnum = $num + 1;
  2313. $l -= length $incnum;
  2314. # pad it out with zeros
  2315. my $padzero = "0" x $l;
  2316. $incnum = ( "0" x $l ) . $incnum;
  2317. }
  2318. else {
  2319. $incnum = $num + 1;
  2320. }
  2321. s/$num/$incnum/;
  2322. }
  2323. my $dbvar = $_;
  2324. my $var = $_;
  2325. my $str;
  2326. my $param;
  2327. if (/<\?lsmb /) {
  2328. while (/<\?lsmb /) {
  2329. s/<\?lsmb .*? \?>//;
  2330. last unless $&;
  2331. $param = $&;
  2332. $str = "";
  2333. if ( $param =~ /<\?lsmb date \?>/i ) {
  2334. $str = (
  2335. $self->split_date(
  2336. $myconfig->{dateformat},
  2337. $self->{transdate}
  2338. )
  2339. )[0];
  2340. $var =~ s/$param/$str/;
  2341. }
  2342. if ( $param =~
  2343. /<\?lsmb (name|business|description|item|partsgroup|phone|custom)/i
  2344. )
  2345. {
  2346. #SC: XXX hairy, undoc, possibly broken
  2347. my $fld = lc $&;
  2348. $fld =~ s/<\?lsmb //;
  2349. if ( $fld =~ /name/ ) {
  2350. if ( $self->{type} ) {
  2351. $fld = $self->{vc};
  2352. }
  2353. }
  2354. my $p = $param;
  2355. $p =~ s/(<|>|%)//g;
  2356. my @p = split / /, $p;
  2357. my @n = split / /, uc $self->{$fld};
  2358. if ( $#p > 0 ) {
  2359. for ( my $i = 1 ; $i <= $#p ; $i++ ) {
  2360. $str .= substr( $n[ $i - 1 ], 0, $p[$i] );
  2361. }
  2362. }
  2363. else {
  2364. ($str) = split /--/, $self->{$fld};
  2365. }
  2366. $var =~ s/$param/$str/;
  2367. $var =~ s/\W//g if $fld eq 'phone';
  2368. }
  2369. if ( $param =~ /<\?lsmb (yy|mm|dd)/i ) {
  2370. # SC: XXX Does this even work anymore?
  2371. my $p = $param;
  2372. $p =~ s/(<|>|%)//g;
  2373. my $spc = $p;
  2374. $spc =~ s/\w//g;
  2375. $spc = substr( $spc, 0, 1 );
  2376. my %d = ( yy => 1, mm => 2, dd => 3 );
  2377. my @p = ();
  2378. my @a = $self->split_date( $myconfig->{dateformat},
  2379. $self->{transdate} );
  2380. for ( sort keys %d ) { push @p, $a[ $d{$_} ] if ( $p =~ /$_/ ) }
  2381. $str = join $spc, @p;
  2382. $var =~ s/$param/$str/;
  2383. }
  2384. if ( $param =~ /<\?lsmb curr/i ) {
  2385. $var =~ s/$param/$self->{currency}/;
  2386. }
  2387. }
  2388. }
  2389. my $query = qq|
  2390. UPDATE defaults
  2391. SET value = ?
  2392. WHERE setting_key = ?|;
  2393. my $sth = $dbh->prepare($query);
  2394. $sth->execute( $dbvar, $fld ) || $self->dberror($query);
  2395. $dbh->commit;
  2396. $var;
  2397. }
  2398. =item $form->db_prepare_vars(var1, var2, ..., varI<n>)
  2399. Undefines $form->{varI<m>}, 1 <= I<m> <= I<n>, iff $form-<{varI<m> is both
  2400. false and not "0".
  2401. =cut
  2402. sub db_prepare_vars {
  2403. my $self = shift;
  2404. for (@_) {
  2405. if ( !$self->{$_} and $self->{$_} ne "0" ) {
  2406. undef $self->{$_};
  2407. }
  2408. }
  2409. }
  2410. =item $form->split_date($dateformat[, $date]);
  2411. Returns ($rv, $yy, $mm, $dd) for the provided $date, or the current date if no
  2412. date is provided. $rv is a seperator-free merging of the fields $yy, $mm, and
  2413. $dd in the ordering supplied by $dateformat. If the supplied $date does not
  2414. contain non-digit characters, $rv is $date and the other return values are
  2415. undefined.
  2416. $yy is two digits.
  2417. =cut
  2418. sub split_date {
  2419. my ( $self, $dateformat, $date ) = @_;
  2420. my $mm;
  2421. my $dd;
  2422. my $yy;
  2423. my $rv;
  2424. if ( !$date ) {
  2425. my @d = localtime;
  2426. $dd = $d[3];
  2427. $mm = ++$d[4];
  2428. $yy = substr( $d[5], -2 );
  2429. $mm = substr( "0$mm", -2 );
  2430. $dd = substr( "0$dd", -2 );
  2431. }
  2432. if ( $dateformat =~ /^yy/ ) {
  2433. if ($date) {
  2434. if ( $date =~ /\D/ ) {
  2435. ( $yy, $mm, $dd ) = split /\D/, $date;
  2436. $mm *= 1;
  2437. $dd *= 1;
  2438. $mm = substr( "0$mm", -2 );
  2439. $dd = substr( "0$dd", -2 );
  2440. $yy = substr( $yy, -2 );
  2441. $rv = "$yy$mm$dd";
  2442. }
  2443. else {
  2444. $rv = $date;
  2445. }
  2446. }
  2447. else {
  2448. $rv = "$yy$mm$dd";
  2449. }
  2450. }
  2451. elsif ( $dateformat =~ /^mm/ ) {
  2452. if ($date) {
  2453. if ( $date =~ /\D/ ) {
  2454. ( $mm, $dd, $yy ) = split /\D/, $date;
  2455. $mm *= 1;
  2456. $dd *= 1;
  2457. $mm = substr( "0$mm", -2 );
  2458. $dd = substr( "0$dd", -2 );
  2459. $yy = substr( $yy, -2 );
  2460. $rv = "$mm$dd$yy";
  2461. }
  2462. else {
  2463. $rv = $date;
  2464. }
  2465. }
  2466. else {
  2467. $rv = "$mm$dd$yy";
  2468. }
  2469. }
  2470. elsif ( $dateformat =~ /^dd/ ) {
  2471. if ($date) {
  2472. if ( $date =~ /\D/ ) {
  2473. ( $dd, $mm, $yy ) = split /\D/, $date;
  2474. $mm *= 1;
  2475. $dd *= 1;
  2476. $mm = substr( "0$mm", -2 );
  2477. $dd = substr( "0$dd", -2 );
  2478. $yy = substr( $yy, -2 );
  2479. $rv = "$dd$mm$yy";
  2480. }
  2481. else {
  2482. $rv = $date;
  2483. }
  2484. }
  2485. else {
  2486. $rv = "$dd$mm$yy";
  2487. }
  2488. }
  2489. ( $rv, $yy, $mm, $dd );
  2490. }
  2491. =item $form->format_date($date);
  2492. Returns $date converted from 'yyyy-mm-dd' format to the format specified by
  2493. $form->{db_dateformat}. If the supplied date does not match /^\d{4}\D/,
  2494. return the supplied date.
  2495. This function takes a four digit year and returns the date with a four digit
  2496. year.
  2497. =cut
  2498. sub format_date {
  2499. # takes an iso date in, and converts it to the date for printing
  2500. my ( $self, $date ) = @_;
  2501. my $datestring;
  2502. if ( $date =~ /^\d{4}\D/ ) { # is an ISO date
  2503. $datestring = $self->{db_dateformat};
  2504. my ( $yyyy, $mm, $dd ) = split( /\W/, $date );
  2505. $datestring =~ s/y+/$yyyy/;
  2506. $datestring =~ s/mm/$mm/;
  2507. $datestring =~ s/dd/$dd/;
  2508. }
  2509. else { # return date
  2510. $datestring = $date;
  2511. }
  2512. $datestring;
  2513. }
  2514. =item $form->from_to($yyyy, $mm[, $interval]);
  2515. Returns the date $yyyy-$mm-01 and the the last day of the month interval - 1
  2516. months from then in the form ($form->format_date(fromdate),
  2517. $form->format_date(later)). If $interval is false but defined, the later date
  2518. is the current date.
  2519. This function dies horribly when $mm + $interval > 24
  2520. =cut
  2521. sub from_to {
  2522. my ( $self, $yyyy, $mm, $interval ) = @_;
  2523. my @t;
  2524. my $dd = 1;
  2525. my $fromdate = "$yyyy-${mm}-01";
  2526. my $bd = 1;
  2527. if ( defined $interval ) {
  2528. if ( $interval == 12 ) {
  2529. $yyyy++;
  2530. }
  2531. else {
  2532. if ( ( $mm += $interval ) > 12 ) {
  2533. $mm -= 12;
  2534. $yyyy++;
  2535. }
  2536. if ( $interval == 0 ) {
  2537. @t = localtime(time);
  2538. $dd = $t[3];
  2539. $mm = $t[4] + 1;
  2540. $yyyy = $t[5] + 1900;
  2541. $bd = 0;
  2542. }
  2543. }
  2544. }
  2545. else {
  2546. if ( ++$mm > 12 ) {
  2547. $mm -= 12;
  2548. $yyyy++;
  2549. }
  2550. }
  2551. $mm--;
  2552. @t = localtime( Time::Local::timelocal( 0, 0, 0, $dd, $mm, $yyyy ) - $bd );
  2553. $t[4]++;
  2554. $t[4] = substr( "0$t[4]", -2 );
  2555. $t[3] = substr( "0$t[3]", -2 );
  2556. $t[5] += 1900;
  2557. return ( $self->format_date($fromdate), $self->format_date("$t[5]-$t[4]-$t[3]") );
  2558. }
  2559. =item $form->audittrail($dbh, $myconfig, $audittrail);
  2560. $audittrail is a hashref. If $audittrail->{id} is false, this function
  2561. retrieves the current time from the database and return a string of the form
  2562. "tablename|reference|formname|action|timestamp|" where all the values save
  2563. timestamp are taken directly from the $audittrail hashref.
  2564. If $audittrail->{id} is true but the value of audittrail in the defaults table
  2565. is '0', do nothing and return.
  2566. If $form->{audittrail} is true and $myconfig is false, $form->{audittrail} is
  2567. treated as a pipe seperated list (trailing pipe required) of the form:
  2568. table1|ref1|form1|action1|date1|...|tablen|refn|formn|actionn|daten|
  2569. All the entries described by $form->{audittrail} are inserted into the audit
  2570. table, taking on a transaction id of $audittrail->{id} and the employee id of
  2571. the calling user.
  2572. Irrespective of $form->{audittrail} and $myconfig status, this function will add
  2573. a record to the audittrail using the values contained within $audittrail,
  2574. substituting the current date if $audittrail->{transdate} is not set and the
  2575. employee id of the calling user.
  2576. =cut
  2577. sub audittrail {
  2578. my ( $self, $dbh, $myconfig, $audittrail ) = @_;
  2579. # table, $reference, $formname, $action, $id, $transdate) = @_;
  2580. my $query;
  2581. my $rv;
  2582. my $disconnect;
  2583. if ( !$dbh ) {
  2584. $dbh = $self->{dbh};
  2585. }
  2586. my $sth;
  2587. my $query;
  2588. # if we have an id add audittrail, otherwise get a new timestamp
  2589. my @queryargs;
  2590. if ( $audittrail->{id} ) {
  2591. $query = qq|
  2592. SELECT value FROM defaults
  2593. WHERE setting_key = 'audittrail'|;
  2594. if ( $dbh->selectrow_array($query) ) {
  2595. my ( $null, $employee_id ) = $self->get_employee($dbh);
  2596. if ( $self->{audittrail} && !$myconfig ) {
  2597. chop $self->{audittrail};
  2598. my @a = split /\|/, $self->{audittrail};
  2599. my %newtrail = ();
  2600. my $key;
  2601. my $i;
  2602. my @flds = qw(tablename reference formname action transdate);
  2603. # put into hash and remove dups
  2604. while (@a) {
  2605. $key = "$a[2]$a[3]";
  2606. $i = 0;
  2607. $newtrail{$key} = { map { $_ => $a[ $i++ ] } @flds };
  2608. splice @a, 0, 5;
  2609. }
  2610. $query = qq|
  2611. INSERT INTO audittrail
  2612. (trans_id, tablename, reference,
  2613. formname, action, transdate,
  2614. employee_id)
  2615. VALUES (?, ?, ?, ?, ?, ?, ?)|;
  2616. my $sth = $dbh->prepare($query) || $self->dberror($query);
  2617. foreach $key (
  2618. sort {
  2619. $newtrail{$a}{transdate} cmp $newtrail{$b}{transdate}
  2620. } keys %newtrail
  2621. )
  2622. {
  2623. $i = 2;
  2624. $sth->bind_param( 1, $audittrail->{id} );
  2625. for (@flds) {
  2626. $sth->bind_param( $i++, $newtrail{$key}{$_} );
  2627. }
  2628. $sth->bind_param( $i++, $employee_id );
  2629. $sth->execute() || $self->dberror($query);
  2630. $sth->finish;
  2631. }
  2632. }
  2633. if ( $audittrail->{transdate} ) {
  2634. $query = qq|
  2635. INSERT INTO audittrail (
  2636. trans_id, tablename, reference,
  2637. formname, action, employee_id,
  2638. transdate)
  2639. VALUES (?, ?, ?, ?, ?, ?, ?)|;
  2640. @queryargs = (
  2641. $audittrail->{id}, $audittrail->{tablename},
  2642. $audittrail->{reference}, $audittrail->{formname},
  2643. $audittrail->{action}, $employee_id,
  2644. $audittrail->{transdate}
  2645. );
  2646. }
  2647. else {
  2648. $query = qq|
  2649. INSERT INTO audittrail
  2650. (trans_id, tablename, reference,
  2651. formname, action, employee_id)
  2652. VALUES (?, ?, ?, ?, ?, ?)|;
  2653. @queryargs = (
  2654. $audittrail->{id}, $audittrail->{tablename},
  2655. $audittrail->{reference}, $audittrail->{formname},
  2656. $audittrail->{action}, $employee_id,
  2657. );
  2658. }
  2659. $sth = $dbh->prepare($query);
  2660. $sth->execute(@queryargs) || $self->dberror($query);
  2661. }
  2662. }
  2663. else {
  2664. $query = qq|SELECT current_timestamp|;
  2665. my ($timestamp) = $dbh->selectrow_array($query);
  2666. $rv =
  2667. "$audittrail->{tablename}|$audittrail->{reference}|$audittrail->{formname}|$audittrail->{action}|$timestamp|";
  2668. }
  2669. $rv;
  2670. }
  2671. 1;
  2672. =back