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