SL/Form.pm

   1 #====================================================================
   2 # LX-Office ERP
   3 # Copyright (C) 2004
   4 # Based on SQL-Ledger Version 2.1.9
   5 # Web http://www.lx-office.org
   6 #
   7 #=====================================================================
   8 # SQL-Ledger Accounting
   9 # Copyright (C) 1998-2002
  10 #
  11 #  Author: Dieter Simader
  12 #   Email: dsimader@sql-ledger.org
  13 #     Web: http://www.sql-ledger.org
  14 #
  15 # Contributors: Thomas Bayen <bayen@gmx.de>
  16 #               Antti Kaihola <akaihola@siba.fi>
  17 #               Moritz Bunkus (tex code)
  18 #
  19 # This program is free software; you can redistribute it and/or modify
  20 # it under the terms of the GNU General Public License as published by
  21 # the Free Software Foundation; either version 2 of the License, or
  22 # (at your option) any later version.
  23 #
  24 # This program is distributed in the hope that it will be useful,
  25 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  26 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  27 # GNU General Public License for more details.
  28 # You should have received a copy of the GNU General Public License
  29 # along with this program; if not, write to the Free Software
  30 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  31 #======================================================================
  32 # Utilities for parsing forms
  33 # and supporting routines for linking account numbers
  34 # used in AR, AP and IS, IR modules
  35 #
  36 #======================================================================
  37
  38 package Form;
  39
  40 use Data::Dumper;
  41
  42 use CGI;
  43 use Cwd;
  44 use Encode;
  45 use File::Copy;
  46 use IO::File;
  47 use SL::Auth;
  48 use SL::Auth::DB;
  49 use SL::Auth::LDAP;
  50 use SL::AM;
  51 use SL::Common;
  52 use SL::CVar;
  53 use SL::DB;
  54 use SL::DBConnect;
  55 use SL::DBUtils;
  56 use SL::DO;
  57 use SL::IC;
  58 use SL::IS;
  59 use SL::Mailer;
  60 use SL::Menu;
  61 use SL::MoreCommon qw(uri_encode uri_decode);
  62 use SL::OE;
  63 use SL::Request;
  64 use SL::Template;
  65 use SL::User;
  66 use SL::X;
  67 use Template;
  68 use URI;
  69 use List::Util qw(first max min sum);
  70 use List::MoreUtils qw(all any apply);
  71
  72 use strict;
  73
  74 my $standard_dbh;
  75
  76 END {
  77   disconnect_standard_dbh();
  78 }
  79
  80 sub disconnect_standard_dbh {
  81   return unless $standard_dbh;
  82   $standard_dbh->disconnect();
  83   undef $standard_dbh;
  84 }
  85
  86 sub new {
  87   $main::lxdebug->enter_sub();
  88
  89   my $type = shift;
  90
  91   my $self = {};
  92
  93   no warnings 'once';
  94   if ($LXDebug::watch_form) {
  95     require SL::Watchdog;
  96     tie %{ $self }, 'SL::Watchdog';
  97   }
  98
  99   bless $self, $type;
 100
 101   open VERSION_FILE, "VERSION";                 # New but flexible code reads version from VERSION-file
 102   $self->{version} =  <VERSION_FILE>;
 103   close VERSION_FILE;
 104   $self->{version}  =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code.
 105
 106   $main::lxdebug->leave_sub();
 107
 108   return $self;
 109 }
 110
 111 sub read_cgi_input {
 112   my ($self) = @_;
 113   SL::Request::read_cgi_input($self);
 114 }
 115
 116 sub _flatten_variables_rec {
 117   $main::lxdebug->enter_sub(2);
 118
 119   my $self   = shift;
 120   my $curr   = shift;
 121   my $prefix = shift;
 122   my $key    = shift;
 123
 124   my @result;
 125
 126   if ('' eq ref $curr->{$key}) {
 127     @result = ({ 'key' => $prefix . $key, 'value' => $curr->{$key} });
 128
 129   } elsif ('HASH' eq ref $curr->{$key}) {
 130     foreach my $hash_key (sort keys %{ $curr->{$key} }) {
 131       push @result, $self->_flatten_variables_rec($curr->{$key}, $prefix . $key . '.', $hash_key);
 132     }
 133
 134   } else {
 135     foreach my $idx (0 .. scalar @{ $curr->{$key} } - 1) {
 136       my $first_array_entry = 1;
 137
 138       foreach my $hash_key (sort keys %{ $curr->{$key}->[$idx] }) {
 139         push @result, $self->_flatten_variables_rec($curr->{$key}->[$idx], $prefix . $key . ($first_array_entry ? '[+].' : '[].'), $hash_key);
 140         $first_array_entry = 0;
 141       }
 142     }
 143   }
 144
 145   $main::lxdebug->leave_sub(2);
 146
 147   return @result;
 148 }
 149
 150 sub flatten_variables {
 151   $main::lxdebug->enter_sub(2);
 152
 153   my $self = shift;
 154   my @keys = @_;
 155
 156   my @variables;
 157
 158   foreach (@keys) {
 159     push @variables, $self->_flatten_variables_rec($self, '', $_);
 160   }
 161
 162   $main::lxdebug->leave_sub(2);
 163
 164   return @variables;
 165 }
 166
 167 sub flatten_standard_variables {
 168   $main::lxdebug->enter_sub(2);
 169
 170   my $self      = shift;
 171   my %skip_keys = map { $_ => 1 } (qw(login password header stylesheet titlebar version), @_);
 172
 173   my @variables;
 174
 175   foreach (grep { ! $skip_keys{$_} } keys %{ $self }) {
 176     push @variables, $self->_flatten_variables_rec($self, '', $_);
 177   }
 178
 179   $main::lxdebug->leave_sub(2);
 180
 181   return @variables;
 182 }
 183
 184 sub debug {
 185   $main::lxdebug->enter_sub();
 186
 187   my ($self) = @_;
 188
 189   print "\n";
 190
 191   map { print "$_ = $self->{$_}\n" } (sort keys %{$self});
 192
 193   $main::lxdebug->leave_sub();
 194 }
 195
 196 sub dumper {
 197   $main::lxdebug->enter_sub(2);
 198
 199   my $self          = shift;
 200   my $password      = $self->{password};
 201
 202   $self->{password} = 'X' x 8;
 203
 204   local $Data::Dumper::Sortkeys = 1;
 205   my $output                    = Dumper($self);
 206
 207   $self->{password} = $password;
 208
 209   $main::lxdebug->leave_sub(2);
 210
 211   return $output;
 212 }
 213
 214 sub escape {
 215   my ($self, $str) = @_;
 216
 217   return uri_encode($str);
 218 }
 219
 220 sub unescape {
 221   my ($self, $str) = @_;
 222
 223   return uri_decode($str);
 224 }
 225
 226 sub quote {
 227   $main::lxdebug->enter_sub();
 228   my ($self, $str) = @_;
 229
 230   if ($str && !ref($str)) {
 231     $str =~ s/\"/&quot;/g;
 232   }
 233
 234   $main::lxdebug->leave_sub();
 235
 236   return $str;
 237 }
 238
 239 sub unquote {
 240   $main::lxdebug->enter_sub();
 241   my ($self, $str) = @_;
 242
 243   if ($str && !ref($str)) {
 244     $str =~ s/&quot;/\"/g;
 245   }
 246
 247   $main::lxdebug->leave_sub();
 248
 249   return $str;
 250 }
 251
 252 sub hide_form {
 253   $main::lxdebug->enter_sub();
 254   my $self = shift;
 255
 256   if (@_) {
 257     map({ print($::request->{cgi}->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_);
 258   } else {
 259     for (sort keys %$self) {
 260       next if (($_ eq "header") || (ref($self->{$_}) ne ""));
 261       print($::request->{cgi}->hidden("-name" => $_, "-default" => $self->{$_}) . "\n");
 262     }
 263   }
 264   $main::lxdebug->leave_sub();
 265 }
 266
 267 sub throw_on_error {
 268   my ($self, $code) = @_;
 269   local $self->{__ERROR_HANDLER} = sub { die SL::X::FormError->new($_[0]) };
 270   $code->();
 271 }
 272
 273 sub error {
 274   $main::lxdebug->enter_sub();
 275
 276   $main::lxdebug->show_backtrace();
 277
 278   my ($self, $msg) = @_;
 279
 280   if ($self->{__ERROR_HANDLER}) {
 281     $self->{__ERROR_HANDLER}->($msg);
 282
 283   } elsif ($ENV{HTTP_USER_AGENT}) {
 284     $msg =~ s/\n/<br>/g;
 285     $self->show_generic_error($msg);
 286
 287   } else {
 288     print STDERR "Error: $msg\n";
 289     ::end_of_request();
 290   }
 291
 292   $main::lxdebug->leave_sub();
 293 }
 294
 295 sub info {
 296   $main::lxdebug->enter_sub();
 297
 298   my ($self, $msg) = @_;
 299
 300   if ($ENV{HTTP_USER_AGENT}) {
 301     $msg =~ s/\n/<br>/g;
 302
 303     if (!$self->{header}) {
 304       $self->header;
 305       print qq|<body>|;
 306     }
 307
 308     print qq|
 309     <p class="message_ok"><b>$msg</b></p>
 310
 311     <script type="text/javascript">
 312     <!--
 313     // If JavaScript is enabled, the whole thing will be reloaded.
 314     // The reason is: When one changes his menu setup (HTML / XUL / CSS ...)
 315     // it now loads the correct code into the browser instead of do nothing.
 316     setTimeout("top.frames.location.href='login.pl'",500);
 317     //-->
 318     </script>
 319
 320 </body>
 321     |;
 322
 323   } else {
 324
 325     if ($self->{info_function}) {
 326       &{ $self->{info_function} }($msg);
 327     } else {
 328       print "$msg\n";
 329     }
 330   }
 331
 332   $main::lxdebug->leave_sub();
 333 }
 334
 335 # calculates the number of rows in a textarea based on the content and column number
 336 # can be capped with maxrows
 337 sub numtextrows {
 338   $main::lxdebug->enter_sub();
 339   my ($self, $str, $cols, $maxrows, $minrows) = @_;
 340
 341   $minrows ||= 1;
 342
 343   my $rows   = sum map { int((length() - 2) / $cols) + 1 } split /\r/, $str;
 344   $maxrows ||= $rows;
 345
 346   $main::lxdebug->leave_sub();
 347
 348   return max(min($rows, $maxrows), $minrows);
 349 }
 350
 351 sub dberror {
 352   $main::lxdebug->enter_sub();
 353
 354   my ($self, $msg) = @_;
 355
 356   $self->error("$msg\n" . $DBI::errstr);
 357
 358   $main::lxdebug->leave_sub();
 359 }
 360
 361 sub isblank {
 362   $main::lxdebug->enter_sub();
 363
 364   my ($self, $name, $msg) = @_;
 365
 366   my $curr = $self;
 367   foreach my $part (split m/\./, $name) {
 368     if (!$curr->{$part} || ($curr->{$part} =~ /^\s*$/)) {
 369       $self->error($msg);
 370     }
 371     $curr = $curr->{$part};
 372   }
 373
 374   $main::lxdebug->leave_sub();
 375 }
 376
 377 sub _get_request_uri {
 378   my $self = shift;
 379
 380   return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
 381
 382   my $scheme =  $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http';
 383   my $port   =  $ENV{SERVER_PORT} || '';
 384   $port      =  undef if (($scheme eq 'http' ) && ($port == 80))
 385                       || (($scheme eq 'https') && ($port == 443));
 386
 387   my $uri    =  URI->new("${scheme}://");
 388   $uri->scheme($scheme);
 389   $uri->port($port);
 390   $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
 391   $uri->path_query($ENV{REQUEST_URI});
 392   $uri->query('');
 393
 394   return $uri;
 395 }
 396
 397 sub _add_to_request_uri {
 398   my $self              = shift;
 399
 400   my $relative_new_path = shift;
 401   my $request_uri       = shift || $self->_get_request_uri;
 402   my $relative_new_uri  = URI->new($relative_new_path);
 403   my @request_segments  = $request_uri->path_segments;
 404
 405   my $new_uri           = $request_uri->clone;
 406   $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments);
 407
 408   return $new_uri;
 409 }
 410
 411 sub create_http_response {
 412   $main::lxdebug->enter_sub();
 413
 414   my $self     = shift;
 415   my %params   = @_;
 416
 417   my $cgi      = $::request->{cgi};
 418
 419   my $session_cookie;
 420   if (defined $main::auth) {
 421     my $uri      = $self->_get_request_uri;
 422     my @segments = $uri->path_segments;
 423     pop @segments;
 424     $uri->path_segments(@segments);
 425
 426     my $session_cookie_value = $main::auth->get_session_id();
 427
 428     if ($session_cookie_value) {
 429       $session_cookie = $cgi->cookie('-name'   => $main::auth->get_session_cookie_name(),
 430                                      '-value'  => $session_cookie_value,
 431                                      '-path'   => $uri->path,
 432                                      '-secure' => $ENV{HTTPS});
 433     }
 434   }
 435
 436   my %cgi_params = ('-type' => $params{content_type});
 437   $cgi_params{'-charset'} = $params{charset} if ($params{charset});
 438   $cgi_params{'-cookie'}  = $session_cookie  if ($session_cookie);
 439
 440   map { $cgi_params{'-' . $_} = $params{$_} if exists $params{$_} } qw(content_disposition content_length);
 441
 442   my $output = $cgi->header(%cgi_params);
 443
 444   $main::lxdebug->leave_sub();
 445
 446   return $output;
 447 }
 448
 449 sub use_stylesheet {
 450   my $self = shift;
 451
 452   $self->{stylesheet} = [ $self->{stylesheet} ] unless ref $self->{stylesheet} eq 'ARRAY';
 453   $self->{stylesheet} = [ grep { -f                       }
 454                           map  { m:^css/: ? $_ : "css/$_" }
 455                           grep { $_                       }
 456                                (@{ $self->{stylesheet} }, @_)
 457                         ];
 458
 459   return @{ $self->{stylesheet} };
 460 }
 461
 462 sub header {
 463   $::lxdebug->enter_sub;
 464
 465   # extra code is currently only used by menuv3 and menuv4 to set their css.
 466   # it is strongly deprecated, and will be changed in a future version.
 467   my ($self, %params) = @_;
 468   my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
 469   my @header;
 470
 471   $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
 472
 473   $self->{favicon} ||= "favicon.ico";
 474   $self->{titlebar}  = "$self->{title} - $self->{titlebar}" if $self->{title};
 475
 476   # build includes
 477   if ($self->{refresh_url} || $self->{refresh_time}) {
 478     my $refresh_time = $self->{refresh_time} || 3;
 479     my $refresh_url  = $self->{refresh_url}  || $ENV{REFERER};
 480     push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
 481   }
 482
 483   push @header, map { qq|<link rel="stylesheet" href="$_" type="text/css" title="Lx-Office stylesheet">| } $self->use_stylesheet;
 484
 485   push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
 486   push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
 487   push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
 488                 '<script type="text/javascript" src="js/common.js"></script>',
 489                 '<link rel="stylesheet" type="text/css" href="js/jscalendar/calendar-win2k-1.css">',
 490                 '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
 491                 '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
 492                 '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
 493                 '<script type="text/javascript" src="js/part_selection.js"></script>',
 494                 '<script type="text/javascript" src="js/jquery-ui.js"></script>',
 495                 '<script type="text/javascript" src="js/jqModal.js"></script>',
 496                 '<link rel="stylesheet" type="text/css" href="css/ui-lightness/jquery-ui-1.8.12.custom.css">';
 497   push @header, $self->{javascript} if $self->{javascript};
 498   push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
 499   push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
 500   push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
 501     join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title};
 502
 503   # if there is a title, we put some JavaScript in to the page, wich writes a
 504   # meaningful title-tag for our frameset.
 505   my $title_hack = '';
 506   if ($self->{title}) {
 507     $title_hack = qq|
 508     <script type="text/javascript">
 509     <!--
 510       // Write a meaningful title-tag for our frameset.
 511       top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
 512     //-->
 513     </script>|;
 514   }
 515
 516   my  %doctypes = (
 517     strict       => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">|,
 518     transitional => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">|,
 519     frameset     => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN" "http://www.w3.org/TR/html4/frameset.dtd">|,
 520   );
 521
 522   # output
 523   print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
 524   print $doctypes{$params{doctype} || 'transitional'}, $/;
 525   print <<EOT;
 526 <html>
 527  <head>
 528   <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
 529   <title>$self->{titlebar}</title>
 530 EOT
 531   print "  $_\n" for @header;
 532   print <<EOT;
 533   <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css">
 534   <meta name="robots" content="noindex,nofollow">
 535   <link rel="stylesheet" type="text/css" href="css/tabcontent.css">
 536   <script type="text/javascript" src="js/tabcontent.js">
 537
 538   /***********************************************
 539    * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
 540    * This notice MUST stay intact for legal use
 541    * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
 542    ***********************************************/
 543
 544   </script>
 545   $params{extra_code}
 546   $title_hack
 547  </head>
 548
 549 EOT
 550
 551   $::lxdebug->leave_sub;
 552 }
 553
 554 sub ajax_response_header {
 555   $main::lxdebug->enter_sub();
 556
 557   my ($self) = @_;
 558
 559   my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
 560   my $output     = $::request->{cgi}->header('-charset' => $db_charset);
 561
 562   $main::lxdebug->leave_sub();
 563
 564   return $output;
 565 }
 566
 567 sub redirect_header {
 568   my $self     = shift;
 569   my $new_url  = shift;
 570
 571   my $base_uri = $self->_get_request_uri;
 572   my $new_uri  = URI->new_abs($new_url, $base_uri);
 573
 574   die "Headers already sent" if $self->{header};
 575   $self->{header} = 1;
 576
 577   return $::request->{cgi}->redirect($new_uri);
 578 }
 579
 580 sub set_standard_title {
 581   $::lxdebug->enter_sub;
 582   my $self = shift;
 583
 584   $self->{titlebar}  = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
 585   $self->{titlebar} .= "- $::myconfig{name}"   if $::myconfig{name};
 586   $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
 587
 588   $::lxdebug->leave_sub;
 589 }
 590
 591 sub _prepare_html_template {
 592   $main::lxdebug->enter_sub();
 593
 594   my ($self, $file, $additional_params) = @_;
 595   my $language;
 596
 597   if (!%::myconfig || !$::myconfig{"countrycode"}) {
 598     $language = $::lx_office_conf{system}->{language};
 599   } else {
 600     $language = $main::myconfig{"countrycode"};
 601   }
 602   $language = "de" unless ($language);
 603
 604   if (-f "templates/webpages/${file}.html") {
 605     $file = "templates/webpages/${file}.html";
 606
 607   } else {
 608     my $info = "Web page template '${file}' not found.\n";
 609     print qq|<pre>$info</pre>|;
 610     ::end_of_request();
 611   }
 612
 613   if ($self->{"DEBUG"}) {
 614     $additional_params->{"DEBUG"} = $self->{"DEBUG"};
 615   }
 616
 617   if ($additional_params->{"DEBUG"}) {
 618     $additional_params->{"DEBUG"} =
 619       "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
 620   }
 621
 622   if (%main::myconfig) {
 623     $::myconfig{jsc_dateformat} = apply {
 624       s/d+/\%d/gi;
 625       s/m+/\%m/gi;
 626       s/y+/\%Y/gi;
 627     } $::myconfig{"dateformat"};
 628     $additional_params->{"myconfig"} ||= \%::myconfig;
 629     map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
 630   }
 631
 632   $additional_params->{"conf_dbcharset"}              = $::lx_office_conf{system}->{dbcharset};
 633   $additional_params->{"conf_webdav"}                 = $::lx_office_conf{features}->{webdav};
 634   $additional_params->{"conf_latex_templates"}        = $::lx_office_conf{print_templates}->{latex};
 635   $additional_params->{"conf_opendocument_templates"} = $::lx_office_conf{print_templates}->{opendocument};
 636   $additional_params->{"conf_vertreter"}              = $::lx_office_conf{features}->{vertreter};
 637   $additional_params->{"conf_show_best_before"}       = $::lx_office_conf{features}->{show_best_before};
 638   $additional_params->{"conf_parts_image_css"}        = $::lx_office_conf{features}->{parts_image_css};
 639   $additional_params->{"conf_parts_listing_images"}   = $::lx_office_conf{features}->{parts_listing_images};
 640   $additional_params->{"conf_parts_show_image"}       = $::lx_office_conf{features}->{parts_show_image};
 641   $additional_params->{"conf_payments_changeable"}    = $::lx_office_conf{features}->{payments_changeable};
 642   $additional_params->{"INSTANCE_CONF"}               = $::instance_conf;
 643
 644   if (my $debug_options = $::lx_office_conf{debug}{options}) {
 645     map { $additional_params->{'DEBUG_' . uc($_)} = $debug_options->{$_} } keys %$debug_options;
 646   }
 647
 648   if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
 649     while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
 650       $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
 651     }
 652   }
 653
 654   $main::lxdebug->leave_sub();
 655
 656   return $file;
 657 }
 658
 659 sub parse_html_template {
 660   $main::lxdebug->enter_sub();
 661
 662   my ($self, $file, $additional_params) = @_;
 663
 664   $additional_params ||= { };
 665
 666   my $real_file = $self->_prepare_html_template($file, $additional_params);
 667   my $template  = $self->template || $self->init_template;
 668
 669   map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
 670
 671   my $output;
 672   $template->process($real_file, $additional_params, \$output) || die $template->error;
 673
 674   $main::lxdebug->leave_sub();
 675
 676   return $output;
 677 }
 678
 679 sub init_template {
 680   my $self = shift;
 681
 682   return $self->template if $self->template;
 683
 684   return $self->template(Template->new({
 685      'INTERPOLATE'  => 0,
 686      'EVAL_PERL'    => 0,
 687      'ABSOLUTE'     => 1,
 688      'CACHE_SIZE'   => 0,
 689      'PLUGIN_BASE'  => 'SL::Template::Plugin',
 690      'INCLUDE_PATH' => '.:templates/webpages',
 691      'COMPILE_EXT'  => '.tcc',
 692      'COMPILE_DIR'  => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
 693   })) || die;
 694 }
 695
 696 sub template {
 697   my $self = shift;
 698   $self->{template_object} = shift if @_;
 699   return $self->{template_object};
 700 }
 701
 702 sub show_generic_error {
 703   $main::lxdebug->enter_sub();
 704
 705   my ($self, $error, %params) = @_;
 706
 707   if ($self->{__ERROR_HANDLER}) {
 708     $self->{__ERROR_HANDLER}->($error);
 709     $main::lxdebug->leave_sub();
 710     return;
 711   }
 712
 713   my $add_params = {
 714     'title_error' => $params{title},
 715     'label_error' => $error,
 716   };
 717
 718   if ($params{action}) {
 719     my @vars;
 720
 721     map { delete($self->{$_}); } qw(action);
 722     map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
 723
 724     $add_params->{SHOW_BUTTON}  = 1;
 725     $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
 726     $add_params->{VARIABLES}    = \@vars;
 727
 728   } elsif ($params{back_button}) {
 729     $add_params->{SHOW_BACK_BUTTON} = 1;
 730   }
 731
 732   $self->{title} = $params{title} if $params{title};
 733
 734   $self->header();
 735   print $self->parse_html_template("generic/error", $add_params);
 736
 737   print STDERR "Error: $error\n";
 738
 739   $main::lxdebug->leave_sub();
 740
 741   ::end_of_request();
 742 }
 743
 744 sub show_generic_information {
 745   $main::lxdebug->enter_sub();
 746
 747   my ($self, $text, $title) = @_;
 748
 749   my $add_params = {
 750     'title_information' => $title,
 751     'label_information' => $text,
 752   };
 753
 754   $self->{title} = $title if ($title);
 755
 756   $self->header();
 757   print $self->parse_html_template("generic/information", $add_params);
 758
 759   $main::lxdebug->leave_sub();
 760
 761   ::end_of_request();
 762 }
 763
 764 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
 765 # changed it to accept an arbitrary number of triggers - sschoeling
 766 sub write_trigger {
 767   $main::lxdebug->enter_sub();
 768
 769   my $self     = shift;
 770   my $myconfig = shift;
 771   my $qty      = shift;
 772
 773   # set dateform for jsscript
 774   # default
 775   my %dateformats = (
 776     "dd.mm.yy" => "%d.%m.%Y",
 777     "dd-mm-yy" => "%d-%m-%Y",
 778     "dd/mm/yy" => "%d/%m/%Y",
 779     "mm/dd/yy" => "%m/%d/%Y",
 780     "mm-dd-yy" => "%m-%d-%Y",
 781     "yyyy-mm-dd" => "%Y-%m-%d",
 782     );
 783
 784   my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
 785     $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
 786
 787   my @triggers;
 788   while ($#_ >= 2) {
 789     push @triggers, qq|
 790        Calendar.setup(
 791       {
 792       inputField : "| . (shift) . qq|",
 793       ifFormat :"$ifFormat",
 794       align : "| .  (shift) . qq|",
 795       button : "| . (shift) . qq|"
 796       }
 797       );
 798        |;
 799   }
 800   my $jsscript = qq|
 801        <script type="text/javascript">
 802        <!--| . join("", @triggers) . qq|//-->
 803         </script>
 804         |;
 805
 806   $main::lxdebug->leave_sub();
 807
 808   return $jsscript;
 809 }    #end sub write_trigger
 810
 811 sub _store_redirect_info_in_session {
 812   my ($self) = @_;
 813
 814   return unless $self->{callback} =~ m:^ ( [^\?/]+ \.pl ) \? (.+) :x;
 815
 816   my ($controller, $params) = ($1, $2);
 817   my $form                  = { map { map { $self->unescape($_) } split /=/, $_, 2 } split m/\&/, $params };
 818   $self->{callback}         = "${controller}?RESTORE_FORM_FROM_SESSION_ID=" . $::auth->save_form_in_session(form => $form);
 819 }
 820
 821 sub redirect {
 822   $main::lxdebug->enter_sub();
 823
 824   my ($self, $msg) = @_;
 825
 826   if (!$self->{callback}) {
 827     $self->info($msg);
 828
 829   } else {
 830     $self->_store_redirect_info_in_session;
 831     print $::form->redirect_header($self->{callback});
 832   }
 833
 834   ::end_of_request();
 835
 836   $main::lxdebug->leave_sub();
 837 }
 838
 839 # sort of columns removed - empty sub
 840 sub sort_columns {
 841   $main::lxdebug->enter_sub();
 842
 843   my ($self, @columns) = @_;
 844
 845   $main::lxdebug->leave_sub();
 846
 847   return @columns;
 848 }
 849 #
 850 sub format_amount {
 851   $main::lxdebug->enter_sub(2);
 852
 853   my ($self, $myconfig, $amount, $places, $dash) = @_;
 854
 855   if ($amount eq "") {
 856     $amount = 0;
 857   }
 858
 859   # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
 860
 861   my $neg = ($amount =~ s/^-//);
 862   my $exp = ($amount =~ m/[e]/) ? 1 : 0;
 863
 864   if (defined($places) && ($places ne '')) {
 865     if (not $exp) {
 866       if ($places < 0) {
 867         $amount *= 1;
 868         $places *= -1;
 869
 870         my ($actual_places) = ($amount =~ /\.(\d+)/);
 871         $actual_places = length($actual_places);
 872         $places = $actual_places > $places ? $actual_places : $places;
 873       }
 874     }
 875     $amount = $self->round_amount($amount, $places);
 876   }
 877
 878   my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
 879   my @p = split(/\./, $amount); # split amount at decimal point
 880
 881   $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
 882
 883   $amount = $p[0];
 884   $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
 885
 886   $amount = do {
 887     ($dash =~ /-/)    ? ($neg ? "($amount)"                            : "$amount" )                              :
 888     ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
 889                         ($neg ? "-$amount"                             : "$amount" )                              ;
 890   };
 891
 892
 893   $main::lxdebug->leave_sub(2);
 894   return $amount;
 895 }
 896
 897 sub format_amount_units {
 898   $main::lxdebug->enter_sub();
 899
 900   my $self             = shift;
 901   my %params           = @_;
 902
 903   my $myconfig         = \%main::myconfig;
 904   my $amount           = $params{amount} * 1;
 905   my $places           = $params{places};
 906   my $part_unit_name   = $params{part_unit};
 907   my $amount_unit_name = $params{amount_unit};
 908   my $conv_units       = $params{conv_units};
 909   my $max_places       = $params{max_places};
 910
 911   if (!$part_unit_name) {
 912     $main::lxdebug->leave_sub();
 913     return '';
 914   }
 915
 916   my $all_units        = AM->retrieve_all_units;
 917
 918   if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
 919     $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
 920   }
 921
 922   if (!scalar @{ $conv_units }) {
 923     my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
 924     $main::lxdebug->leave_sub();
 925     return $result;
 926   }
 927
 928   my $part_unit  = $all_units->{$part_unit_name};
 929   my $conv_unit  = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
 930
 931   $amount       *= $conv_unit->{factor};
 932
 933   my @values;
 934   my $num;
 935
 936   foreach my $unit (@$conv_units) {
 937     my $last = $unit->{name} eq $part_unit->{name};
 938     if (!$last) {
 939       $num     = int($amount / $unit->{factor});
 940       $amount -= $num * $unit->{factor};
 941     }
 942
 943     if ($last ? $amount : $num) {
 944       push @values, { "unit"   => $unit->{name},
 945                       "amount" => $last ? $amount / $unit->{factor} : $num,
 946                       "places" => $last ? $places : 0 };
 947     }
 948
 949     last if $last;
 950   }
 951
 952   if (!@values) {
 953     push @values, { "unit"   => $part_unit_name,
 954                     "amount" => 0,
 955                     "places" => 0 };
 956   }
 957
 958   my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
 959
 960   $main::lxdebug->leave_sub();
 961
 962   return $result;
 963 }
 964
 965 sub format_string {
 966   $main::lxdebug->enter_sub(2);
 967
 968   my $self  = shift;
 969   my $input = shift;
 970
 971   $input =~ s/(^|[^\#]) \#  (\d+)  /$1$_[$2 - 1]/gx;
 972   $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
 973   $input =~ s/\#\#/\#/g;
 974
 975   $main::lxdebug->leave_sub(2);
 976
 977   return $input;
 978 }
 979
 980 #
 981
 982 sub parse_amount {
 983   $main::lxdebug->enter_sub(2);
 984
 985   my ($self, $myconfig, $amount) = @_;
 986
 987   if (   ($myconfig->{numberformat} eq '1.000,00')
 988       || ($myconfig->{numberformat} eq '1000,00')) {
 989     $amount =~ s/\.//g;
 990     $amount =~ s/,/\./g;
 991   }
 992
 993   if ($myconfig->{numberformat} eq "1'000.00") {
 994     $amount =~ s/\'//g;
 995   }
 996
 997   $amount =~ s/,//g;
 998
 999   $main::lxdebug->leave_sub(2);
1000
1001   # Make sure no code wich is not a math expression ends up in eval().
1002   return 0 unless $amount =~ /^ [\s \d \( \) \- \+ \* \/ \. ]* $/x;
1003   return scalar(eval($amount)) * 1 ;
1004 }
1005
1006 sub round_amount {
1007   $main::lxdebug->enter_sub(2);
1008
1009   my ($self, $amount, $places) = @_;
1010   my $round_amount;
1011
1012   # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1013
1014   # Round amounts to eight places before rounding to the requested
1015   # number of places. This gets rid of errors due to internal floating
1016   # point representation.
1017   $amount       = $self->round_amount($amount, 8) if $places < 8;
1018   $amount       = $amount * (10**($places));
1019   $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1020
1021   $main::lxdebug->leave_sub(2);
1022
1023   return $round_amount;
1024
1025 }
1026
1027 sub parse_template {
1028   $main::lxdebug->enter_sub();
1029
1030   my ($self, $myconfig) = @_;
1031   my ($out, $out_mode);
1032
1033   local (*IN, *OUT);
1034
1035   my $userspath = $::lx_office_conf{paths}->{userspath};
1036
1037   $self->{"cwd"} = getcwd();
1038   $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1039
1040   my $ext_for_format;
1041
1042   my $template_type;
1043   if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1044     $template_type  = 'OpenDocument';
1045     $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1046
1047   } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1048     $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1049     $template_type    = 'LaTeX';
1050     $ext_for_format   = 'pdf';
1051
1052   } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1053     $template_type  = 'HTML';
1054     $ext_for_format = 'html';
1055
1056   } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1057     $template_type  = 'XML';
1058     $ext_for_format = 'xml';
1059
1060   } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1061     $template_type = 'XML';
1062
1063   } elsif ( $self->{"format"} =~ /excel/i ) {
1064     $template_type  = 'Excel';
1065     $ext_for_format = 'xls';
1066
1067   } elsif ( defined $self->{'format'}) {
1068     $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1069
1070   } elsif ( $self->{'format'} eq '' ) {
1071     $self->error("No Outputformat given: $self->{'format'}");
1072
1073   } else { #Catch the rest
1074     $self->error("Outputformat not defined: $self->{'format'}");
1075   }
1076
1077   my $template = SL::Template::create(type      => $template_type,
1078                                       file_name => $self->{IN},
1079                                       form      => $self,
1080                                       myconfig  => $myconfig,
1081                                       userspath => $userspath);
1082
1083   # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1084   $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1085
1086   if (!$self->{employee_id}) {
1087     map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1088   }
1089
1090   map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1091   map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1092
1093   $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1094
1095   # OUT is used for the media, screen, printer, email
1096   # for postscript we store a copy in a temporary file
1097   my $fileid = time;
1098   my $prepend_userspath;
1099
1100   if (!$self->{tmpfile}) {
1101     $self->{tmpfile}   = "${fileid}.$self->{IN}";
1102     $prepend_userspath = 1;
1103   }
1104
1105   $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1106
1107   $self->{tmpfile} =~ s|.*/||;
1108   $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1109   $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1110
1111   if ($template->uses_temp_file() || $self->{media} eq 'email') {
1112     $out = $self->{OUT};
1113     $out_mode = $self->{OUT_MODE} || '>';
1114     $self->{OUT} = "$self->{tmpfile}";
1115     $self->{OUT_MODE} = '>';
1116   }
1117
1118   my $result;
1119
1120   if ($self->{OUT}) {
1121     open(OUT, $self->{OUT_MODE}, $self->{OUT}) or $self->error("error on opening $self->{OUT} with mode $self->{OUT_MODE} : $!");
1122   } else {
1123     *OUT = ($::dispatcher->get_standard_filehandles)[1];
1124     $self->header;
1125   }
1126
1127   if (!$template->parse(*OUT)) {
1128     $self->cleanup();
1129     $self->error("$self->{IN} : " . $template->get_error());
1130   }
1131
1132   close OUT if $self->{OUT};
1133
1134   if ($self->{media} eq 'file') {
1135     copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1136     $self->cleanup;
1137     chdir("$self->{cwd}");
1138
1139     $::lxdebug->leave_sub();
1140
1141     return;
1142   }
1143
1144   if ($template->uses_temp_file() || $self->{media} eq 'email') {
1145
1146     if ($self->{media} eq 'email') {
1147
1148       my $mail = new Mailer;
1149
1150       map { $mail->{$_} = $self->{$_} }
1151         qw(cc bcc subject message version format);
1152       $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1153       $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1154       $mail->{from}   = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1155       $mail->{fileid} = "$fileid.";
1156       $myconfig->{signature} =~ s/\r//g;
1157
1158       # if we send html or plain text inline
1159       if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1160         $mail->{contenttype} = "text/html";
1161
1162         $mail->{message}       =~ s/\r//g;
1163         $mail->{message}       =~ s/\n/<br>\n/g;
1164         $myconfig->{signature} =~ s/\n/<br>\n/g;
1165         $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1166
1167         open(IN, "<", $self->{tmpfile})
1168           or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1169         while (<IN>) {
1170           $mail->{message} .= $_;
1171         }
1172
1173         close(IN);
1174
1175       } else {
1176
1177         if (!$self->{"do_not_attach"}) {
1178           my $attachment_name  =  $self->{attachment_filename} || $self->{tmpfile};
1179           $attachment_name     =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1180           $mail->{attachments} =  [{ "filename" => $self->{tmpfile},
1181                                      "name"     => $attachment_name }];
1182         }
1183
1184         $mail->{message}  =~ s/\r//g;
1185         $mail->{message} .=  "\n-- \n$myconfig->{signature}";
1186
1187       }
1188
1189       my $err = $mail->send();
1190       $self->error($self->cleanup . "$err") if ($err);
1191
1192     } else {
1193
1194       $self->{OUT}      = $out;
1195       $self->{OUT_MODE} = $out_mode;
1196
1197       my $numbytes = (-s $self->{tmpfile});
1198       open(IN, "<", $self->{tmpfile})
1199         or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1200       binmode IN;
1201
1202       $self->{copies} = 1 unless $self->{media} eq 'printer';
1203
1204       chdir("$self->{cwd}");
1205       #print(STDERR "Kopien $self->{copies}\n");
1206       #print(STDERR "OUT $self->{OUT}\n");
1207       for my $i (1 .. $self->{copies}) {
1208         if ($self->{OUT}) {
1209           open OUT, $self->{OUT_MODE}, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1210           print OUT $_ while <IN>;
1211           close OUT;
1212           seek IN, 0, 0;
1213
1214         } else {
1215           $self->{attachment_filename} = ($self->{attachment_filename})
1216                                        ? $self->{attachment_filename}
1217                                        : $self->generate_attachment_filename();
1218
1219           # launch application
1220           print qq|Content-Type: | . $template->get_mime_type() . qq|
1221 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1222 Content-Length: $numbytes
1223
1224 |;
1225
1226           $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1227         }
1228       }
1229
1230       close(IN);
1231     }
1232
1233   }
1234
1235   $self->cleanup;
1236
1237   chdir("$self->{cwd}");
1238   $main::lxdebug->leave_sub();
1239 }
1240
1241 sub get_formname_translation {
1242   $main::lxdebug->enter_sub();
1243   my ($self, $formname) = @_;
1244
1245   $formname ||= $self->{formname};
1246
1247   my %formname_translations = (
1248     bin_list                => $main::locale->text('Bin List'),
1249     credit_note             => $main::locale->text('Credit Note'),
1250     invoice                 => $main::locale->text('Invoice'),
1251     pick_list               => $main::locale->text('Pick List'),
1252     proforma                => $main::locale->text('Proforma Invoice'),
1253     purchase_order          => $main::locale->text('Purchase Order'),
1254     request_quotation       => $main::locale->text('RFQ'),
1255     sales_order             => $main::locale->text('Confirmation'),
1256     sales_quotation         => $main::locale->text('Quotation'),
1257     storno_invoice          => $main::locale->text('Storno Invoice'),
1258     sales_delivery_order    => $main::locale->text('Delivery Order'),
1259     purchase_delivery_order => $main::locale->text('Delivery Order'),
1260     dunning                 => $main::locale->text('Dunning'),
1261   );
1262
1263   $main::lxdebug->leave_sub();
1264   return $formname_translations{$formname}
1265 }
1266
1267 sub get_number_prefix_for_type {
1268   $main::lxdebug->enter_sub();
1269   my ($self) = @_;
1270
1271   my $prefix =
1272       (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1273     : ($self->{type} =~ /_quotation$/)                        ? 'quo'
1274     : ($self->{type} =~ /_delivery_order$/)                   ? 'do'
1275     :                                                           'ord';
1276
1277   $main::lxdebug->leave_sub();
1278   return $prefix;
1279 }
1280
1281 sub get_extension_for_format {
1282   $main::lxdebug->enter_sub();
1283   my ($self)    = @_;
1284
1285   my $extension = $self->{format} =~ /pdf/i          ? ".pdf"
1286                 : $self->{format} =~ /postscript/i   ? ".ps"
1287                 : $self->{format} =~ /opendocument/i ? ".odt"
1288                 : $self->{format} =~ /excel/i        ? ".xls"
1289                 : $self->{format} =~ /html/i         ? ".html"
1290                 :                                      "";
1291
1292   $main::lxdebug->leave_sub();
1293   return $extension;
1294 }
1295
1296 sub generate_attachment_filename {
1297   $main::lxdebug->enter_sub();
1298   my ($self) = @_;
1299
1300   my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1301   my $prefix              = $self->get_number_prefix_for_type();
1302
1303   if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1304     $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1305
1306   } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1307     $attachment_filename .=  "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1308
1309   } else {
1310     $attachment_filename = "";
1311   }
1312
1313   $attachment_filename =  $main::locale->quote_special_chars('filenames', $attachment_filename);
1314   $attachment_filename =~ s|[\s/\\]+|_|g;
1315
1316   $main::lxdebug->leave_sub();
1317   return $attachment_filename;
1318 }
1319
1320 sub generate_email_subject {
1321   $main::lxdebug->enter_sub();
1322   my ($self) = @_;
1323
1324   my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1325   my $prefix  = $self->get_number_prefix_for_type();
1326
1327   if ($subject && $self->{"${prefix}number"}) {
1328     $subject .= " " . $self->{"${prefix}number"}
1329   }
1330
1331   $main::lxdebug->leave_sub();
1332   return $subject;
1333 }
1334
1335 sub cleanup {
1336   $main::lxdebug->enter_sub();
1337
1338   my ($self, $application) = @_;
1339
1340   my $error_code = $?;
1341
1342   chdir("$self->{tmpdir}");
1343
1344   my @err = ();
1345   if ((-1 == $error_code) || (127 == (($error_code) >> 8))) {
1346     push @err, $::locale->text('The application "#1" was not found on the system.', $application || 'pdflatex') . ' ' . $::locale->text('Please contact your administrator.');
1347
1348   } elsif (-f "$self->{tmpfile}.err") {
1349     open(FH, "$self->{tmpfile}.err");
1350     @err = <FH>;
1351     close(FH);
1352   }
1353
1354   if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1355     $self->{tmpfile} =~ s|.*/||g;
1356     # strip extension
1357     $self->{tmpfile} =~ s/\.\w+$//g;
1358     my $tmpfile = $self->{tmpfile};
1359     unlink(<$tmpfile.*>);
1360   }
1361
1362   chdir("$self->{cwd}");
1363
1364   $main::lxdebug->leave_sub();
1365
1366   return "@err";
1367 }
1368
1369 sub datetonum {
1370   $main::lxdebug->enter_sub();
1371
1372   my ($self, $date, $myconfig) = @_;
1373   my ($yy, $mm, $dd);
1374
1375   if ($date && $date =~ /\D/) {
1376
1377     if ($myconfig->{dateformat} =~ /^yy/) {
1378       ($yy, $mm, $dd) = split /\D/, $date;
1379     }
1380     if ($myconfig->{dateformat} =~ /^mm/) {
1381       ($mm, $dd, $yy) = split /\D/, $date;
1382     }
1383     if ($myconfig->{dateformat} =~ /^dd/) {
1384       ($dd, $mm, $yy) = split /\D/, $date;
1385     }
1386
1387     $dd *= 1;
1388     $mm *= 1;
1389     $yy = ($yy < 70) ? $yy + 2000 : $yy;
1390     $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1391
1392     $dd = "0$dd" if ($dd < 10);
1393     $mm = "0$mm" if ($mm < 10);
1394
1395     $date = "$yy$mm$dd";
1396   }
1397
1398   $main::lxdebug->leave_sub();
1399
1400   return $date;
1401 }
1402
1403 # Database routines used throughout
1404
1405 sub _dbconnect_options {
1406   my $self    = shift;
1407   my $options = { pg_enable_utf8 => $::locale->is_utf8,
1408                   @_ };
1409
1410   return $options;
1411 }
1412
1413 sub dbconnect {
1414   $main::lxdebug->enter_sub(2);
1415
1416   my ($self, $myconfig) = @_;
1417
1418   # connect to database
1419   my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1420     or $self->dberror;
1421
1422   # set db options
1423   if ($myconfig->{dboptions}) {
1424     $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1425   }
1426
1427   $main::lxdebug->leave_sub(2);
1428
1429   return $dbh;
1430 }
1431
1432 sub dbconnect_noauto {
1433   $main::lxdebug->enter_sub();
1434
1435   my ($self, $myconfig) = @_;
1436
1437   # connect to database
1438   my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1439     or $self->dberror;
1440
1441   # set db options
1442   if ($myconfig->{dboptions}) {
1443     $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1444   }
1445
1446   $main::lxdebug->leave_sub();
1447
1448   return $dbh;
1449 }
1450
1451 sub get_standard_dbh {
1452   $main::lxdebug->enter_sub(2);
1453
1454   my $self     = shift;
1455   my $myconfig = shift || \%::myconfig;
1456
1457   if ($standard_dbh && !$standard_dbh->{Active}) {
1458     $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1459     undef $standard_dbh;
1460   }
1461
1462   $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1463
1464   $main::lxdebug->leave_sub(2);
1465
1466   return $standard_dbh;
1467 }
1468
1469 sub date_closed {
1470   $main::lxdebug->enter_sub();
1471
1472   my ($self, $date, $myconfig) = @_;
1473   my $dbh = $self->dbconnect($myconfig);
1474
1475   my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1476   my $sth = prepare_execute_query($self, $dbh, $query, conv_date($date));
1477
1478   # Falls $date = '' - Fehlermeldung aus der Datenbank. Ich denke,
1479   # es ist sicher ein conv_date vorher IMMER auszuführen.
1480   # Testfälle ohne definiertes closedto:
1481   #   Leere Datumseingabe i.O.
1482   #     SELECT 1 FROM defaults WHERE '' < closedto
1483   #   normale Zahlungsbuchung über Rechnungsmaske i.O.
1484   #     SELECT 1 FROM defaults WHERE '10.05.2011' < closedto
1485   # Testfälle mit definiertem closedto (30.04.2011):
1486   #  Leere Datumseingabe i.O.
1487   #   SELECT 1 FROM defaults WHERE '' < closedto
1488   # normale Buchung im geschloßenem Zeitraum i.O.
1489   #   SELECT 1 FROM defaults WHERE '21.04.2011' < closedto
1490   #     Fehlermeldung: Es können keine Zahlungen für abgeschlossene Bücher gebucht werden!
1491   # normale Buchung in aktiver Buchungsperiode i.O.
1492   #   SELECT 1 FROM defaults WHERE '01.05.2011' < closedto
1493
1494   my ($closed) = $sth->fetchrow_array;
1495
1496   $main::lxdebug->leave_sub();
1497
1498   return $closed;
1499 }
1500
1501 sub update_balance {
1502   $main::lxdebug->enter_sub();
1503
1504   my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1505
1506   # if we have a value, go do it
1507   if ($value != 0) {
1508
1509     # retrieve balance from table
1510     my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1511     my $sth = prepare_execute_query($self, $dbh, $query, @values);
1512     my ($balance) = $sth->fetchrow_array;
1513     $sth->finish;
1514
1515     $balance += $value;
1516
1517     # update balance
1518     $query = "UPDATE $table SET $field = $balance WHERE $where";
1519     do_query($self, $dbh, $query, @values);
1520   }
1521   $main::lxdebug->leave_sub();
1522 }
1523
1524 sub update_exchangerate {
1525   $main::lxdebug->enter_sub();
1526
1527   my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1528   my ($query);
1529   # some sanity check for currency
1530   if ($curr eq '') {
1531     $main::lxdebug->leave_sub();
1532     return;
1533   }
1534   $query = qq|SELECT curr FROM defaults|;
1535
1536   my ($currency) = selectrow_query($self, $dbh, $query);
1537   my ($defaultcurrency) = split m/:/, $currency;
1538
1539
1540   if ($curr eq $defaultcurrency) {
1541     $main::lxdebug->leave_sub();
1542     return;
1543   }
1544
1545   $query = qq|SELECT e.curr FROM exchangerate e
1546                  WHERE e.curr = ? AND e.transdate = ?
1547                  FOR UPDATE|;
1548   my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1549
1550   if ($buy == 0) {
1551     $buy = "";
1552   }
1553   if ($sell == 0) {
1554     $sell = "";
1555   }
1556
1557   $buy = conv_i($buy, "NULL");
1558   $sell = conv_i($sell, "NULL");
1559
1560   my $set;
1561   if ($buy != 0 && $sell != 0) {
1562     $set = "buy = $buy, sell = $sell";
1563   } elsif ($buy != 0) {
1564     $set = "buy = $buy";
1565   } elsif ($sell != 0) {
1566     $set = "sell = $sell";
1567   }
1568
1569   if ($sth->fetchrow_array) {
1570     $query = qq|UPDATE exchangerate
1571                 SET $set
1572                 WHERE curr = ?
1573                 AND transdate = ?|;
1574
1575   } else {
1576     $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1577                 VALUES (?, $buy, $sell, ?)|;
1578   }
1579   $sth->finish;
1580   do_query($self, $dbh, $query, $curr, $transdate);
1581
1582   $main::lxdebug->leave_sub();
1583 }
1584
1585 sub save_exchangerate {
1586   $main::lxdebug->enter_sub();
1587
1588   my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1589
1590   my $dbh = $self->dbconnect($myconfig);
1591
1592   my ($buy, $sell);
1593
1594   $buy  = $rate if $fld eq 'buy';
1595   $sell = $rate if $fld eq 'sell';
1596
1597
1598   $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1599
1600
1601   $dbh->disconnect;
1602
1603   $main::lxdebug->leave_sub();
1604 }
1605
1606 sub get_exchangerate {
1607   $main::lxdebug->enter_sub();
1608
1609   my ($self, $dbh, $curr, $transdate, $fld) = @_;
1610   my ($query);
1611
1612   unless ($transdate) {
1613     $main::lxdebug->leave_sub();
1614     return 1;
1615   }
1616
1617   $query = qq|SELECT curr FROM defaults|;
1618
1619   my ($currency) = selectrow_query($self, $dbh, $query);
1620   my ($defaultcurrency) = split m/:/, $currency;
1621
1622   if ($currency eq $defaultcurrency) {
1623     $main::lxdebug->leave_sub();
1624     return 1;
1625   }
1626
1627   $query = qq|SELECT e.$fld FROM exchangerate e
1628                  WHERE e.curr = ? AND e.transdate = ?|;
1629   my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1630
1631
1632
1633   $main::lxdebug->leave_sub();
1634
1635   return $exchangerate;
1636 }
1637
1638 sub check_exchangerate {
1639   $main::lxdebug->enter_sub();
1640
1641   my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1642
1643   if ($fld !~/^buy|sell$/) {
1644     $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1645   }
1646
1647   unless ($transdate) {
1648     $main::lxdebug->leave_sub();
1649     return "";
1650   }
1651
1652   my ($defaultcurrency) = $self->get_default_currency($myconfig);
1653
1654   if ($currency eq $defaultcurrency) {
1655     $main::lxdebug->leave_sub();
1656     return 1;
1657   }
1658
1659   my $dbh   = $self->get_standard_dbh($myconfig);
1660   my $query = qq|SELECT e.$fld FROM exchangerate e
1661                  WHERE e.curr = ? AND e.transdate = ?|;
1662
1663   my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1664
1665   $main::lxdebug->leave_sub();
1666
1667   return $exchangerate;
1668 }
1669
1670 sub get_all_currencies {
1671   $main::lxdebug->enter_sub();
1672
1673   my $self     = shift;
1674   my $myconfig = shift || \%::myconfig;
1675   my $dbh      = $self->get_standard_dbh($myconfig);
1676
1677   my $query = qq|SELECT curr FROM defaults|;
1678
1679   my ($curr)     = selectrow_query($self, $dbh, $query);
1680   my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1681
1682   $main::lxdebug->leave_sub();
1683
1684   return @currencies;
1685 }
1686
1687 sub get_default_currency {
1688   $main::lxdebug->enter_sub();
1689
1690   my ($self, $myconfig) = @_;
1691   my @currencies        = $self->get_all_currencies($myconfig);
1692
1693   $main::lxdebug->leave_sub();
1694
1695   return $currencies[0];
1696 }
1697
1698 sub set_payment_options {
1699   $main::lxdebug->enter_sub();
1700
1701   my ($self, $myconfig, $transdate) = @_;
1702
1703   return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1704
1705   my $dbh = $self->get_standard_dbh($myconfig);
1706
1707   my $query =
1708     qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long , p.description | .
1709     qq|FROM payment_terms p | .
1710     qq|WHERE p.id = ?|;
1711
1712   ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1713    $self->{payment_terms}, $self->{payment_description}) =
1714      selectrow_query($self, $dbh, $query, $self->{payment_id});
1715
1716   if ($transdate eq "") {
1717     if ($self->{invdate}) {
1718       $transdate = $self->{invdate};
1719     } else {
1720       $transdate = $self->{transdate};
1721     }
1722   }
1723
1724   $query =
1725     qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1726     qq|FROM payment_terms|;
1727   ($self->{netto_date}, $self->{skonto_date}) =
1728     selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1729
1730   my ($invtotal, $total);
1731   my (%amounts, %formatted_amounts);
1732
1733   if ($self->{type} =~ /_order$/) {
1734     $amounts{invtotal} = $self->{ordtotal};
1735     $amounts{total}    = $self->{ordtotal};
1736
1737   } elsif ($self->{type} =~ /_quotation$/) {
1738     $amounts{invtotal} = $self->{quototal};
1739     $amounts{total}    = $self->{quototal};
1740
1741   } else {
1742     $amounts{invtotal} = $self->{invtotal};
1743     $amounts{total}    = $self->{total};
1744   }
1745   $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1746
1747   map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1748
1749   $amounts{skonto_amount}      = $amounts{invtotal} * $self->{percent_skonto};
1750   $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1751   $amounts{total_wo_skonto}    = $amounts{total}    * (1 - $self->{percent_skonto});
1752
1753   foreach (keys %amounts) {
1754     $amounts{$_}           = $self->round_amount($amounts{$_}, 2);
1755     $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1756   }
1757
1758   if ($self->{"language_id"}) {
1759     $query =
1760       qq|SELECT t.translation, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1761       qq|FROM generic_translations t | .
1762       qq|LEFT JOIN language l ON t.language_id = l.id | .
1763       qq|WHERE (t.language_id = ?)
1764            AND (t.translation_id = ?)
1765            AND (t.translation_type = 'SL::DB::PaymentTerm/description_long')|;
1766     my ($description_long, $output_numberformat, $output_dateformat,
1767       $output_longdates) =
1768       selectrow_query($self, $dbh, $query,
1769                       $self->{"language_id"}, $self->{"payment_id"});
1770
1771     $self->{payment_terms} = $description_long if ($description_long);
1772
1773     if ($output_dateformat) {
1774       foreach my $key (qw(netto_date skonto_date)) {
1775         $self->{$key} =
1776           $main::locale->reformat_date($myconfig, $self->{$key},
1777                                        $output_dateformat,
1778                                        $output_longdates);
1779       }
1780     }
1781
1782     if ($output_numberformat &&
1783         ($output_numberformat ne $myconfig->{"numberformat"})) {
1784       my $saved_numberformat = $myconfig->{"numberformat"};
1785       $myconfig->{"numberformat"} = $output_numberformat;
1786       map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1787       $myconfig->{"numberformat"} = $saved_numberformat;
1788     }
1789   }
1790
1791   $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1792   $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1793   $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1794   $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1795   $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1796   $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1797   $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1798
1799   map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1800
1801   $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1802
1803   $main::lxdebug->leave_sub();
1804
1805 }
1806
1807 sub get_template_language {
1808   $main::lxdebug->enter_sub();
1809
1810   my ($self, $myconfig) = @_;
1811
1812   my $template_code = "";
1813
1814   if ($self->{language_id}) {
1815     my $dbh = $self->get_standard_dbh($myconfig);
1816     my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1817     ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1818   }
1819
1820   $main::lxdebug->leave_sub();
1821
1822   return $template_code;
1823 }
1824
1825 sub get_printer_code {
1826   $main::lxdebug->enter_sub();
1827
1828   my ($self, $myconfig) = @_;
1829
1830   my $template_code = "";
1831
1832   if ($self->{printer_id}) {
1833     my $dbh = $self->get_standard_dbh($myconfig);
1834     my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1835     ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1836   }
1837
1838   $main::lxdebug->leave_sub();
1839
1840   return $template_code;
1841 }
1842
1843 sub get_shipto {
1844   $main::lxdebug->enter_sub();
1845
1846   my ($self, $myconfig) = @_;
1847
1848   my $template_code = "";
1849
1850   if ($self->{shipto_id}) {
1851     my $dbh = $self->get_standard_dbh($myconfig);
1852     my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1853     my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1854     map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1855   }
1856
1857   $main::lxdebug->leave_sub();
1858 }
1859
1860 sub add_shipto {
1861   $main::lxdebug->enter_sub();
1862
1863   my ($self, $dbh, $id, $module) = @_;
1864
1865   my $shipto;
1866   my @values;
1867
1868   foreach my $item (qw(name department_1 department_2 street zipcode city country
1869                        contact cp_gender phone fax email)) {
1870     if ($self->{"shipto$item"}) {
1871       $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1872     }
1873     push(@values, $self->{"shipto${item}"});
1874   }
1875
1876   if ($shipto) {
1877     if ($self->{shipto_id}) {
1878       my $query = qq|UPDATE shipto set
1879                        shiptoname = ?,
1880                        shiptodepartment_1 = ?,
1881                        shiptodepartment_2 = ?,
1882                        shiptostreet = ?,
1883                        shiptozipcode = ?,
1884                        shiptocity = ?,
1885                        shiptocountry = ?,
1886                        shiptocontact = ?,
1887                        shiptocp_gender = ?,
1888                        shiptophone = ?,
1889                        shiptofax = ?,
1890                        shiptoemail = ?
1891                      WHERE shipto_id = ?|;
1892       do_query($self, $dbh, $query, @values, $self->{shipto_id});
1893     } else {
1894       my $query = qq|SELECT * FROM shipto
1895                      WHERE shiptoname = ? AND
1896                        shiptodepartment_1 = ? AND
1897                        shiptodepartment_2 = ? AND
1898                        shiptostreet = ? AND
1899                        shiptozipcode = ? AND
1900                        shiptocity = ? AND
1901                        shiptocountry = ? AND
1902                        shiptocontact = ? AND
1903                        shiptocp_gender = ? AND
1904                        shiptophone = ? AND
1905                        shiptofax = ? AND
1906                        shiptoemail = ? AND
1907                        module = ? AND
1908                        trans_id = ?|;
1909       my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
1910       if(!$insert_check){
1911         $query =
1912           qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
1913                                  shiptostreet, shiptozipcode, shiptocity, shiptocountry,
1914                                  shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
1915              VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
1916         do_query($self, $dbh, $query, $id, @values, $module);
1917       }
1918     }
1919   }
1920
1921   $main::lxdebug->leave_sub();
1922 }
1923
1924 sub get_employee {
1925   $main::lxdebug->enter_sub();
1926
1927   my ($self, $dbh) = @_;
1928
1929   $dbh ||= $self->get_standard_dbh(\%main::myconfig);
1930
1931   my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
1932   ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
1933   $self->{"employee_id"} *= 1;
1934
1935   $main::lxdebug->leave_sub();
1936 }
1937
1938 sub get_employee_data {
1939   $main::lxdebug->enter_sub();
1940
1941   my $self     = shift;
1942   my %params   = @_;
1943
1944   Common::check_params(\%params, qw(prefix));
1945   Common::check_params_x(\%params, qw(id));
1946
1947   if (!$params{id}) {
1948     $main::lxdebug->leave_sub();
1949     return;
1950   }
1951
1952   my $myconfig = \%main::myconfig;
1953   my $dbh      = $params{dbh} || $self->get_standard_dbh($myconfig);
1954
1955   my ($login)  = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
1956
1957   if ($login) {
1958     my $user = User->new($login);
1959     map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
1960
1961     $self->{$params{prefix} . '_login'}   = $login;
1962     $self->{$params{prefix} . '_name'}  ||= $login;
1963   }
1964
1965   $main::lxdebug->leave_sub();
1966 }
1967
1968 sub get_duedate {
1969   $main::lxdebug->enter_sub();
1970
1971   my ($self, $myconfig, $reference_date) = @_;
1972
1973   $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
1974
1975   my $dbh         = $self->get_standard_dbh($myconfig);
1976   my $query       = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
1977   my ($duedate)   = selectrow_query($self, $dbh, $query, $self->{payment_id});
1978
1979   $main::lxdebug->leave_sub();
1980
1981   return $duedate;
1982 }
1983
1984 sub _get_contacts {
1985   $main::lxdebug->enter_sub();
1986
1987   my ($self, $dbh, $id, $key) = @_;
1988
1989   $key = "all_contacts" unless ($key);
1990
1991   if (!$id) {
1992     $self->{$key} = [];
1993     $main::lxdebug->leave_sub();
1994     return;
1995   }
1996
1997   my $query =
1998     qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
1999     qq|FROM contacts | .
2000     qq|WHERE cp_cv_id = ? | .
2001     qq|ORDER BY lower(cp_name)|;
2002
2003   $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2004
2005   $main::lxdebug->leave_sub();
2006 }
2007
2008 sub _get_projects {
2009   $main::lxdebug->enter_sub();
2010
2011   my ($self, $dbh, $key) = @_;
2012
2013   my ($all, $old_id, $where, @values);
2014
2015   if (ref($key) eq "HASH") {
2016     my $params = $key;
2017
2018     $key = "ALL_PROJECTS";
2019
2020     foreach my $p (keys(%{$params})) {
2021       if ($p eq "all") {
2022         $all = $params->{$p};
2023       } elsif ($p eq "old_id") {
2024         $old_id = $params->{$p};
2025       } elsif ($p eq "key") {
2026         $key = $params->{$p};
2027       }
2028     }
2029   }
2030
2031   if (!$all) {
2032     $where = "WHERE active ";
2033     if ($old_id) {
2034       if (ref($old_id) eq "ARRAY") {
2035         my @ids = grep({ $_ } @{$old_id});
2036         if (@ids) {
2037           $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2038           push(@values, @ids);
2039         }
2040       } else {
2041         $where .= " OR (id = ?) ";
2042         push(@values, $old_id);
2043       }
2044     }
2045   }
2046
2047   my $query =
2048     qq|SELECT id, projectnumber, description, active | .
2049     qq|FROM project | .
2050     $where .
2051     qq|ORDER BY lower(projectnumber)|;
2052
2053   $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2054
2055   $main::lxdebug->leave_sub();
2056 }
2057
2058 sub _get_shipto {
2059   $main::lxdebug->enter_sub();
2060
2061   my ($self, $dbh, $vc_id, $key) = @_;
2062
2063   $key = "all_shipto" unless ($key);
2064
2065   if ($vc_id) {
2066     # get shipping addresses
2067     my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2068
2069     $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2070
2071   } else {
2072     $self->{$key} = [];
2073   }
2074
2075   $main::lxdebug->leave_sub();
2076 }
2077
2078 sub _get_printers {
2079   $main::lxdebug->enter_sub();
2080
2081   my ($self, $dbh, $key) = @_;
2082
2083   $key = "all_printers" unless ($key);
2084
2085   my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2086
2087   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2088
2089   $main::lxdebug->leave_sub();
2090 }
2091
2092 sub _get_charts {
2093   $main::lxdebug->enter_sub();
2094
2095   my ($self, $dbh, $params) = @_;
2096   my ($key);
2097
2098   $key = $params->{key};
2099   $key = "all_charts" unless ($key);
2100
2101   my $transdate = quote_db_date($params->{transdate});
2102
2103   my $query =
2104     qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2105     qq|FROM chart c | .
2106     qq|LEFT JOIN taxkeys tk ON | .
2107     qq|(tk.id = (SELECT id FROM taxkeys | .
2108     qq|          WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2109     qq|          ORDER BY startdate DESC LIMIT 1)) | .
2110     qq|ORDER BY c.accno|;
2111
2112   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2113
2114   $main::lxdebug->leave_sub();
2115 }
2116
2117 sub _get_taxcharts {
2118   $main::lxdebug->enter_sub();
2119
2120   my ($self, $dbh, $params) = @_;
2121
2122   my $key = "all_taxcharts";
2123   my @where;
2124
2125   if (ref $params eq 'HASH') {
2126     $key = $params->{key} if ($params->{key});
2127     if ($params->{module} eq 'AR') {
2128       push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2129
2130     } elsif ($params->{module} eq 'AP') {
2131       push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2132     }
2133
2134   } elsif ($params) {
2135     $key = $params;
2136   }
2137
2138   my $where = @where ? ' WHERE ' . join(' AND ', map { "($_)" } @where) : '';
2139
2140   my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2141
2142   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2143
2144   $main::lxdebug->leave_sub();
2145 }
2146
2147 sub _get_taxzones {
2148   $main::lxdebug->enter_sub();
2149
2150   my ($self, $dbh, $key) = @_;
2151
2152   $key = "all_taxzones" unless ($key);
2153
2154   my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2155
2156   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2157
2158   $main::lxdebug->leave_sub();
2159 }
2160
2161 sub _get_employees {
2162   $main::lxdebug->enter_sub();
2163
2164   my ($self, $dbh, $default_key, $key) = @_;
2165
2166   $key = $default_key unless ($key);
2167   $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2168
2169   $main::lxdebug->leave_sub();
2170 }
2171
2172 sub _get_business_types {
2173   $main::lxdebug->enter_sub();
2174
2175   my ($self, $dbh, $key) = @_;
2176
2177   my $options       = ref $key eq 'HASH' ? $key : { key => $key };
2178   $options->{key} ||= "all_business_types";
2179   my $where         = '';
2180
2181   if (exists $options->{salesman}) {
2182     $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2183   }
2184
2185   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2186
2187   $main::lxdebug->leave_sub();
2188 }
2189
2190 sub _get_languages {
2191   $main::lxdebug->enter_sub();
2192
2193   my ($self, $dbh, $key) = @_;
2194
2195   $key = "all_languages" unless ($key);
2196
2197   my $query = qq|SELECT * FROM language ORDER BY id|;
2198
2199   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2200
2201   $main::lxdebug->leave_sub();
2202 }
2203
2204 sub _get_dunning_configs {
2205   $main::lxdebug->enter_sub();
2206
2207   my ($self, $dbh, $key) = @_;
2208
2209   $key = "all_dunning_configs" unless ($key);
2210
2211   my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2212
2213   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2214
2215   $main::lxdebug->leave_sub();
2216 }
2217
2218 sub _get_currencies {
2219 $main::lxdebug->enter_sub();
2220
2221   my ($self, $dbh, $key) = @_;
2222
2223   $key = "all_currencies" unless ($key);
2224
2225   my $query = qq|SELECT curr AS currency FROM defaults|;
2226
2227   $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2228
2229   $main::lxdebug->leave_sub();
2230 }
2231
2232 sub _get_payments {
2233 $main::lxdebug->enter_sub();
2234
2235   my ($self, $dbh, $key) = @_;
2236
2237   $key = "all_payments" unless ($key);
2238
2239   my $query = qq|SELECT * FROM payment_terms ORDER BY sortkey|;
2240
2241   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2242
2243   $main::lxdebug->leave_sub();
2244 }
2245
2246 sub _get_customers {
2247   $main::lxdebug->enter_sub();
2248
2249   my ($self, $dbh, $key) = @_;
2250
2251   my $options        = ref $key eq 'HASH' ? $key : { key => $key };
2252   $options->{key}  ||= "all_customers";
2253   my $limit_clause   = $options->{limit} ? "LIMIT $options->{limit}" : '';
2254
2255   my @where;
2256   push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if  $options->{business_is_salesman};
2257   push @where, qq|NOT obsolete|                                            if !$options->{with_obsolete};
2258   my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2259
2260   my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2261   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2262
2263   $main::lxdebug->leave_sub();
2264 }
2265
2266 sub _get_vendors {
2267   $main::lxdebug->enter_sub();
2268
2269   my ($self, $dbh, $key) = @_;
2270
2271   $key = "all_vendors" unless ($key);
2272
2273   my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2274
2275   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2276
2277   $main::lxdebug->leave_sub();
2278 }
2279
2280 sub _get_departments {
2281   $main::lxdebug->enter_sub();
2282
2283   my ($self, $dbh, $key) = @_;
2284
2285   $key = "all_departments" unless ($key);
2286
2287   my $query = qq|SELECT * FROM department ORDER BY description|;
2288
2289   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2290
2291   $main::lxdebug->leave_sub();
2292 }
2293
2294 sub _get_warehouses {
2295   $main::lxdebug->enter_sub();
2296
2297   my ($self, $dbh, $param) = @_;
2298
2299   my ($key, $bins_key);
2300
2301   if ('' eq ref $param) {
2302     $key = $param;
2303
2304   } else {
2305     $key      = $param->{key};
2306     $bins_key = $param->{bins};
2307   }
2308
2309   my $query = qq|SELECT w.* FROM warehouse w
2310                  WHERE (NOT w.invalid) AND
2311                    ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2312                  ORDER BY w.sortkey|;
2313
2314   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2315
2316   if ($bins_key) {
2317     $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?
2318                 ORDER BY description|;
2319     my $sth = prepare_query($self, $dbh, $query);
2320
2321     foreach my $warehouse (@{ $self->{$key} }) {
2322       do_statement($self, $sth, $query, $warehouse->{id});
2323       $warehouse->{$bins_key} = [];
2324
2325       while (my $ref = $sth->fetchrow_hashref()) {
2326         push @{ $warehouse->{$bins_key} }, $ref;
2327       }
2328     }
2329     $sth->finish();
2330   }
2331
2332   $main::lxdebug->leave_sub();
2333 }
2334
2335 sub _get_simple {
2336   $main::lxdebug->enter_sub();
2337
2338   my ($self, $dbh, $table, $key, $sortkey) = @_;
2339
2340   my $query  = qq|SELECT * FROM $table|;
2341   $query    .= qq| ORDER BY $sortkey| if ($sortkey);
2342
2343   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2344
2345   $main::lxdebug->leave_sub();
2346 }
2347
2348 #sub _get_groups {
2349 #  $main::lxdebug->enter_sub();
2350 #
2351 #  my ($self, $dbh, $key) = @_;
2352 #
2353 #  $key ||= "all_groups";
2354 #
2355 #  my $groups = $main::auth->read_groups();
2356 #
2357 #  $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2358 #
2359 #  $main::lxdebug->leave_sub();
2360 #}
2361
2362 sub get_lists {
2363   $main::lxdebug->enter_sub();
2364
2365   my $self = shift;
2366   my %params = @_;
2367
2368   my $dbh = $self->get_standard_dbh(\%main::myconfig);
2369   my ($sth, $query, $ref);
2370
2371   my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2372   my $vc_id = $self->{"${vc}_id"};
2373
2374   if ($params{"contacts"}) {
2375     $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2376   }
2377
2378   if ($params{"shipto"}) {
2379     $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2380   }
2381
2382   if ($params{"projects"} || $params{"all_projects"}) {
2383     $self->_get_projects($dbh, $params{"all_projects"} ?
2384                          $params{"all_projects"} : $params{"projects"},
2385                          $params{"all_projects"} ? 1 : 0);
2386   }
2387
2388   if ($params{"printers"}) {
2389     $self->_get_printers($dbh, $params{"printers"});
2390   }
2391
2392   if ($params{"languages"}) {
2393     $self->_get_languages($dbh, $params{"languages"});
2394   }
2395
2396   if ($params{"charts"}) {
2397     $self->_get_charts($dbh, $params{"charts"});
2398   }
2399
2400   if ($params{"taxcharts"}) {
2401     $self->_get_taxcharts($dbh, $params{"taxcharts"});
2402   }
2403
2404   if ($params{"taxzones"}) {
2405     $self->_get_taxzones($dbh, $params{"taxzones"});
2406   }
2407
2408   if ($params{"employees"}) {
2409     $self->_get_employees($dbh, "all_employees", $params{"employees"});
2410   }
2411
2412   if ($params{"salesmen"}) {
2413     $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2414   }
2415
2416   if ($params{"business_types"}) {
2417     $self->_get_business_types($dbh, $params{"business_types"});
2418   }
2419
2420   if ($params{"dunning_configs"}) {
2421     $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2422   }
2423
2424   if($params{"currencies"}) {
2425     $self->_get_currencies($dbh, $params{"currencies"});
2426   }
2427
2428   if($params{"customers"}) {
2429     $self->_get_customers($dbh, $params{"customers"});
2430   }
2431
2432   if($params{"vendors"}) {
2433     if (ref $params{"vendors"} eq 'HASH') {
2434       $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2435     } else {
2436       $self->_get_vendors($dbh, $params{"vendors"});
2437     }
2438   }
2439
2440   if($params{"payments"}) {
2441     $self->_get_payments($dbh, $params{"payments"});
2442   }
2443
2444   if($params{"departments"}) {
2445     $self->_get_departments($dbh, $params{"departments"});
2446   }
2447
2448   if ($params{price_factors}) {
2449     $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2450   }
2451
2452   if ($params{warehouses}) {
2453     $self->_get_warehouses($dbh, $params{warehouses});
2454   }
2455
2456 #  if ($params{groups}) {
2457 #    $self->_get_groups($dbh, $params{groups});
2458 #  }
2459
2460   if ($params{partsgroup}) {
2461     $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2462   }
2463
2464   $main::lxdebug->leave_sub();
2465 }
2466
2467 # this sub gets the id and name from $table
2468 sub get_name {
2469   $main::lxdebug->enter_sub();
2470
2471   my ($self, $myconfig, $table) = @_;
2472
2473   # connect to database
2474   my $dbh = $self->get_standard_dbh($myconfig);
2475
2476   $table = $table eq "customer" ? "customer" : "vendor";
2477   my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2478
2479   my ($query, @values);
2480
2481   if (!$self->{openinvoices}) {
2482     my $where;
2483     if ($self->{customernumber} ne "") {
2484       $where = qq|(vc.customernumber ILIKE ?)|;
2485       push(@values, '%' . $self->{customernumber} . '%');
2486     } else {
2487       $where = qq|(vc.name ILIKE ?)|;
2488       push(@values, '%' . $self->{$table} . '%');
2489     }
2490
2491     $query =
2492       qq~SELECT vc.id, vc.name,
2493            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2494          FROM $table vc
2495          WHERE $where AND (NOT vc.obsolete)
2496          ORDER BY vc.name~;
2497   } else {
2498     $query =
2499       qq~SELECT DISTINCT vc.id, vc.name,
2500            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2501          FROM $arap a
2502          JOIN $table vc ON (a.${table}_id = vc.id)
2503          WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2504          ORDER BY vc.name~;
2505     push(@values, '%' . $self->{$table} . '%');
2506   }
2507
2508   $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2509
2510   $main::lxdebug->leave_sub();
2511
2512   return scalar(@{ $self->{name_list} });
2513 }
2514
2515 # the selection sub is used in the AR, AP, IS, IR and OE module
2516 #
2517 sub all_vc {
2518   $main::lxdebug->enter_sub();
2519
2520   my ($self, $myconfig, $table, $module) = @_;
2521
2522   my $ref;
2523   my $dbh = $self->get_standard_dbh;
2524
2525   $table = $table eq "customer" ? "customer" : "vendor";
2526
2527   my $query = qq|SELECT count(*) FROM $table|;
2528   my ($count) = selectrow_query($self, $dbh, $query);
2529
2530   # build selection list
2531   if ($count <= $myconfig->{vclimit}) {
2532     $query = qq|SELECT id, name, salesman_id
2533                 FROM $table WHERE NOT obsolete
2534                 ORDER BY name|;
2535     $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2536   }
2537
2538   # get self
2539   $self->get_employee($dbh);
2540
2541   # setup sales contacts
2542   $query = qq|SELECT e.id, e.name
2543               FROM employee e
2544               WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2545   $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2546
2547   # this is for self
2548   push(@{ $self->{all_employees} },
2549        { id   => $self->{employee_id},
2550          name => $self->{employee} });
2551
2552   # sort the whole thing
2553   @{ $self->{all_employees} } =
2554     sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2555
2556
2557     # prepare query for departments
2558     $query = qq|SELECT id, description
2559                 FROM department
2560                 ORDER BY description|;
2561
2562   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2563
2564   # get languages
2565   $query = qq|SELECT id, description
2566               FROM language
2567               ORDER BY id|;
2568
2569   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2570
2571   # get printer
2572   $query = qq|SELECT printer_description, id
2573               FROM printers
2574               ORDER BY printer_description|;
2575
2576   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2577
2578   # get payment terms
2579   $query = qq|SELECT id, description
2580               FROM payment_terms
2581               ORDER BY sortkey|;
2582
2583   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2584
2585   $main::lxdebug->leave_sub();
2586 }
2587
2588 sub language_payment {
2589   $main::lxdebug->enter_sub();
2590
2591   my ($self, $myconfig) = @_;
2592
2593   my $dbh = $self->get_standard_dbh($myconfig);
2594   # get languages
2595   my $query = qq|SELECT id, description
2596                  FROM language
2597                  ORDER BY id|;
2598
2599   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2600
2601   # get printer
2602   $query = qq|SELECT printer_description, id
2603               FROM printers
2604               ORDER BY printer_description|;
2605
2606   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2607
2608   # get payment terms
2609   $query = qq|SELECT id, description
2610               FROM payment_terms
2611               ORDER BY sortkey|;
2612
2613   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2614
2615   # get buchungsgruppen
2616   $query = qq|SELECT id, description
2617               FROM buchungsgruppen|;
2618
2619   $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2620
2621   $main::lxdebug->leave_sub();
2622 }
2623
2624 # this is only used for reports
2625 sub all_departments {
2626   $main::lxdebug->enter_sub();
2627
2628   my ($self, $myconfig, $table) = @_;
2629
2630   my $dbh = $self->get_standard_dbh($myconfig);
2631
2632   my $query = qq|SELECT id, description
2633                  FROM department
2634                  ORDER BY description|;
2635   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2636
2637   delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2638
2639   $main::lxdebug->leave_sub();
2640 }
2641
2642 sub create_links {
2643   $main::lxdebug->enter_sub();
2644
2645   my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2646
2647   my ($fld, $arap);
2648   if ($table eq "customer") {
2649     $fld = "buy";
2650     $arap = "ar";
2651   } else {
2652     $table = "vendor";
2653     $fld = "sell";
2654     $arap = "ap";
2655   }
2656
2657   $self->all_vc($myconfig, $table, $module);
2658
2659   # get last customers or vendors
2660   my ($query, $sth, $ref);
2661
2662   my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2663   my %xkeyref = ();
2664
2665   if (!$self->{id}) {
2666
2667     my $transdate = "current_date";
2668     if ($self->{transdate}) {
2669       $transdate = $dbh->quote($self->{transdate});
2670     }
2671
2672     # now get the account numbers
2673 #    $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2674 #                FROM chart c, taxkeys tk
2675 #                WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2676 #                  (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2677 #                ORDER BY c.accno|;
2678
2679 #  same query as above, but without expensive subquery for each row. about 80% faster
2680     $query = qq|
2681       SELECT c.accno, c.description, c.link, c.taxkey_id, tk2.tax_id
2682         FROM chart c
2683         -- find newest entries in taxkeys
2684         INNER JOIN (
2685           SELECT chart_id, MAX(startdate) AS startdate
2686           FROM taxkeys
2687           WHERE (startdate <= $transdate)
2688           GROUP BY chart_id
2689         ) tk ON (c.id = tk.chart_id)
2690         -- and load all of those entries
2691         INNER JOIN taxkeys tk2
2692            ON (tk.chart_id = tk2.chart_id AND tk.startdate = tk2.startdate)
2693        WHERE (c.link LIKE ?)
2694       ORDER BY c.accno|;
2695
2696     $sth = $dbh->prepare($query);
2697
2698     do_statement($self, $sth, $query, '%' . $module . '%');
2699
2700     $self->{accounts} = "";
2701     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2702
2703       foreach my $key (split(/:/, $ref->{link})) {
2704         if ($key =~ /\Q$module\E/) {
2705
2706           # cross reference for keys
2707           $xkeyref{ $ref->{accno} } = $key;
2708
2709           push @{ $self->{"${module}_links"}{$key} },
2710             { accno       => $ref->{accno},
2711               description => $ref->{description},
2712               taxkey      => $ref->{taxkey_id},
2713               tax_id      => $ref->{tax_id} };
2714
2715           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2716         }
2717       }
2718     }
2719   }
2720
2721   # get taxkeys and description
2722   $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2723   $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2724
2725   if (($module eq "AP") || ($module eq "AR")) {
2726     # get tax rates and description
2727     $query = qq|SELECT * FROM tax|;
2728     $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2729   }
2730
2731   if ($self->{id}) {
2732     $query =
2733       qq|SELECT
2734            a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2735            a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2736            a.intnotes, a.department_id, a.amount AS oldinvtotal,
2737            a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2738            a.globalproject_id,
2739            c.name AS $table,
2740            d.description AS department,
2741            e.name AS employee
2742          FROM $arap a
2743          JOIN $table c ON (a.${table}_id = c.id)
2744          LEFT JOIN employee e ON (e.id = a.employee_id)
2745          LEFT JOIN department d ON (d.id = a.department_id)
2746          WHERE a.id = ?|;
2747     $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2748
2749     foreach my $key (keys %$ref) {
2750       $self->{$key} = $ref->{$key};
2751     }
2752
2753     # remove any trailing whitespace
2754     $self->{currency} =~ s/\s*$//;
2755
2756     my $transdate = "current_date";
2757     if ($self->{transdate}) {
2758       $transdate = $dbh->quote($self->{transdate});
2759     }
2760
2761     # now get the account numbers
2762     $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2763                 FROM chart c
2764                 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2765                 WHERE c.link LIKE ?
2766                   AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2767                     OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2768                 ORDER BY c.accno|;
2769
2770     $sth = $dbh->prepare($query);
2771     do_statement($self, $sth, $query, "%$module%");
2772
2773     $self->{accounts} = "";
2774     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2775
2776       foreach my $key (split(/:/, $ref->{link})) {
2777         if ($key =~ /\Q$module\E/) {
2778
2779           # cross reference for keys
2780           $xkeyref{ $ref->{accno} } = $key;
2781
2782           push @{ $self->{"${module}_links"}{$key} },
2783             { accno       => $ref->{accno},
2784               description => $ref->{description},
2785               taxkey      => $ref->{taxkey_id},
2786               tax_id      => $ref->{tax_id} };
2787
2788           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2789         }
2790       }
2791     }
2792
2793
2794     # get amounts from individual entries
2795     $query =
2796       qq|SELECT
2797            c.accno, c.description,
2798            a.acc_trans_id, a.source, a.amount, a.memo, a.transdate, a.gldate, a.cleared, a.project_id, a.taxkey,
2799            p.projectnumber,
2800            t.rate, t.id
2801          FROM acc_trans a
2802          LEFT JOIN chart c ON (c.id = a.chart_id)
2803          LEFT JOIN project p ON (p.id = a.project_id)
2804          LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2805                                     WHERE (tk.taxkey_id=a.taxkey) AND
2806                                       ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2807                                         THEN tk.chart_id = a.chart_id
2808                                         ELSE 1 = 1
2809                                         END)
2810                                        OR (c.link='%tax%')) AND
2811                                       (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2812          WHERE a.trans_id = ?
2813          AND a.fx_transaction = '0'
2814          ORDER BY a.acc_trans_id, a.transdate|;
2815     $sth = $dbh->prepare($query);
2816     do_statement($self, $sth, $query, $self->{id});
2817
2818     # get exchangerate for currency
2819     $self->{exchangerate} =
2820       $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2821     my $index = 0;
2822
2823     # store amounts in {acc_trans}{$key} for multiple accounts
2824     while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2825       $ref->{exchangerate} =
2826         $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2827       if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2828         $index++;
2829       }
2830       if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2831         $ref->{amount} *= -1;
2832       }
2833       $ref->{index} = $index;
2834
2835       push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2836     }
2837
2838     $sth->finish;
2839     $query =
2840       qq|SELECT
2841            d.curr AS currencies, d.closedto, d.revtrans,
2842            (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2843            (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2844          FROM defaults d|;
2845     $ref = selectfirst_hashref_query($self, $dbh, $query);
2846     map { $self->{$_} = $ref->{$_} } keys %$ref;
2847
2848   } else {
2849
2850     # get date
2851     $query =
2852        qq|SELECT
2853             current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2854             (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2855             (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2856           FROM defaults d|;
2857     $ref = selectfirst_hashref_query($self, $dbh, $query);
2858     map { $self->{$_} = $ref->{$_} } keys %$ref;
2859
2860     if ($self->{"$self->{vc}_id"}) {
2861
2862       # only setup currency
2863       ($self->{currency}) = split(/:/, $self->{currencies});
2864
2865     } else {
2866
2867       $self->lastname_used($dbh, $myconfig, $table, $module);
2868
2869       # get exchangerate for currency
2870       $self->{exchangerate} =
2871         $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2872
2873     }
2874
2875   }
2876
2877   $main::lxdebug->leave_sub();
2878 }
2879
2880 sub lastname_used {
2881   $main::lxdebug->enter_sub();
2882
2883   my ($self, $dbh, $myconfig, $table, $module) = @_;
2884
2885   my ($arap, $where);
2886
2887   $table         = $table eq "customer" ? "customer" : "vendor";
2888   my %column_map = ("a.curr"                  => "currency",
2889                     "a.${table}_id"           => "${table}_id",
2890                     "a.department_id"         => "department_id",
2891                     "d.description"           => "department",
2892                     "ct.name"                 => $table,
2893                     "ct.curr"                 => "cv_curr",
2894                     "current_date + ct.terms" => "duedate",
2895     );
2896
2897   if ($self->{type} =~ /delivery_order/) {
2898     $arap  = 'delivery_orders';
2899     delete $column_map{"a.curr"};
2900     delete $column_map{"ct.curr"};
2901
2902   } elsif ($self->{type} =~ /_order/) {
2903     $arap  = 'oe';
2904     $where = "quotation = '0'";
2905
2906   } elsif ($self->{type} =~ /_quotation/) {
2907     $arap  = 'oe';
2908     $where = "quotation = '1'";
2909
2910   } elsif ($table eq 'customer') {
2911     $arap  = 'ar';
2912
2913   } else {
2914     $arap  = 'ap';
2915
2916   }
2917
2918   $where           = "($where) AND" if ($where);
2919   my $query        = qq|SELECT MAX(id) FROM $arap
2920                         WHERE $where ${table}_id > 0|;
2921   my ($trans_id)   = selectrow_query($self, $dbh, $query);
2922   $trans_id       *= 1;
2923
2924   my $column_spec  = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
2925   $query           = qq|SELECT $column_spec
2926                         FROM $arap a
2927                         LEFT JOIN $table     ct ON (a.${table}_id = ct.id)
2928                         LEFT JOIN department d  ON (a.department_id = d.id)
2929                         WHERE a.id = ?|;
2930   my $ref          = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
2931
2932   map { $self->{$_} = $ref->{$_} } values %column_map;
2933
2934   # remove any trailing whitespace
2935   $self->{currency} =~ s/\s*$// if $self->{currency};
2936   $self->{cv_curr} =~ s/\s*$// if $self->{cv_curr};
2937
2938   # if customer/vendor currency is set use this
2939   $self->{currency} = $self->{cv_curr} if $self->{cv_curr};
2940
2941   $main::lxdebug->leave_sub();
2942 }
2943
2944 sub current_date {
2945   $main::lxdebug->enter_sub();
2946
2947   my $self     = shift;
2948   my $myconfig = shift || \%::myconfig;
2949   my ($thisdate, $days) = @_;
2950
2951   my $dbh = $self->get_standard_dbh($myconfig);
2952   my $query;
2953
2954   $days *= 1;
2955   if ($thisdate) {
2956     my $dateformat = $myconfig->{dateformat};
2957     $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
2958     $thisdate = $dbh->quote($thisdate);
2959     $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
2960   } else {
2961     $query = qq|SELECT current_date AS thisdate|;
2962   }
2963
2964   ($thisdate) = selectrow_query($self, $dbh, $query);
2965
2966   $main::lxdebug->leave_sub();
2967
2968   return $thisdate;
2969 }
2970
2971 sub like {
2972   $main::lxdebug->enter_sub();
2973
2974   my ($self, $string) = @_;
2975
2976   if ($string !~ /%/) {
2977     $string = "%$string%";
2978   }
2979
2980   $string =~ s/\'/\'\'/g;
2981
2982   $main::lxdebug->leave_sub();
2983
2984   return $string;
2985 }
2986
2987 sub redo_rows {
2988   $main::lxdebug->enter_sub();
2989
2990   my ($self, $flds, $new, $count, $numrows) = @_;
2991
2992   my @ndx = ();
2993
2994   map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
2995
2996   my $i = 0;
2997
2998   # fill rows
2999   foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3000     $i++;
3001     my $j = $item->{ndx} - 1;
3002     map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3003   }
3004
3005   # delete empty rows
3006   for $i ($count + 1 .. $numrows) {
3007     map { delete $self->{"${_}_$i"} } @{$flds};
3008   }
3009
3010   $main::lxdebug->leave_sub();
3011 }
3012
3013 sub update_status {
3014   $main::lxdebug->enter_sub();
3015
3016   my ($self, $myconfig) = @_;
3017
3018   my ($i, $id);
3019
3020   my $dbh = $self->dbconnect_noauto($myconfig);
3021
3022   my $query = qq|DELETE FROM status
3023                  WHERE (formname = ?) AND (trans_id = ?)|;
3024   my $sth = prepare_query($self, $dbh, $query);
3025
3026   if ($self->{formname} =~ /(check|receipt)/) {
3027     for $i (1 .. $self->{rowcount}) {
3028       do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3029     }
3030   } else {
3031     do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3032   }
3033   $sth->finish();
3034
3035   my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3036   my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3037
3038   my %queued = split / /, $self->{queued};
3039   my @values;
3040
3041   if ($self->{formname} =~ /(check|receipt)/) {
3042
3043     # this is a check or receipt, add one entry for each lineitem
3044     my ($accno) = split /--/, $self->{account};
3045     $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3046                 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3047     @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3048     $sth = prepare_query($self, $dbh, $query);
3049
3050     for $i (1 .. $self->{rowcount}) {
3051       if ($self->{"checked_$i"}) {
3052         do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3053       }
3054     }
3055     $sth->finish();
3056
3057   } else {
3058     $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3059                 VALUES (?, ?, ?, ?, ?)|;
3060     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3061              $queued{$self->{formname}}, $self->{formname});
3062   }
3063
3064   $dbh->commit;
3065   $dbh->disconnect;
3066
3067   $main::lxdebug->leave_sub();
3068 }
3069
3070 sub save_status {
3071   $main::lxdebug->enter_sub();
3072
3073   my ($self, $dbh) = @_;
3074
3075   my ($query, $printed, $emailed);
3076
3077   my $formnames  = $self->{printed};
3078   my $emailforms = $self->{emailed};
3079
3080   $query = qq|DELETE FROM status
3081                  WHERE (formname = ?) AND (trans_id = ?)|;
3082   do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3083
3084   # this only applies to the forms
3085   # checks and receipts are posted when printed or queued
3086
3087   if ($self->{queued}) {
3088     my %queued = split / /, $self->{queued};
3089
3090     foreach my $formname (keys %queued) {
3091       $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3092       $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3093
3094       $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3095                   VALUES (?, ?, ?, ?, ?)|;
3096       do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3097
3098       $formnames  =~ s/\Q$self->{formname}\E//;
3099       $emailforms =~ s/\Q$self->{formname}\E//;
3100
3101     }
3102   }
3103
3104   # save printed, emailed info
3105   $formnames  =~ s/^ +//g;
3106   $emailforms =~ s/^ +//g;
3107
3108   my %status = ();
3109   map { $status{$_}{printed} = 1 } split / +/, $formnames;
3110   map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3111
3112   foreach my $formname (keys %status) {
3113     $printed = ($formnames  =~ /\Q$self->{formname}\E/) ? "1" : "0";
3114     $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3115
3116     $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3117                 VALUES (?, ?, ?, ?)|;
3118     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3119   }
3120
3121   $main::lxdebug->leave_sub();
3122 }
3123
3124 #--- 4 locale ---#
3125 # $main::locale->text('SAVED')
3126 # $main::locale->text('DELETED')
3127 # $main::locale->text('ADDED')
3128 # $main::locale->text('PAYMENT POSTED')
3129 # $main::locale->text('POSTED')
3130 # $main::locale->text('POSTED AS NEW')
3131 # $main::locale->text('ELSE')
3132 # $main::locale->text('SAVED FOR DUNNING')
3133 # $main::locale->text('DUNNING STARTED')
3134 # $main::locale->text('PRINTED')
3135 # $main::locale->text('MAILED')
3136 # $main::locale->text('SCREENED')
3137 # $main::locale->text('CANCELED')
3138 # $main::locale->text('invoice')
3139 # $main::locale->text('proforma')
3140 # $main::locale->text('sales_order')
3141 # $main::locale->text('pick_list')
3142 # $main::locale->text('purchase_order')
3143 # $main::locale->text('bin_list')
3144 # $main::locale->text('sales_quotation')
3145 # $main::locale->text('request_quotation')
3146
3147 sub save_history {
3148   $main::lxdebug->enter_sub();
3149
3150   my $self = shift;
3151   my $dbh  = shift || $self->get_standard_dbh;
3152
3153   if(!exists $self->{employee_id}) {
3154     &get_employee($self, $dbh);
3155   }
3156
3157   my $query =
3158    qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3159    qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3160   my @values = (conv_i($self->{id}), $self->{login},
3161                 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3162   do_query($self, $dbh, $query, @values);
3163
3164   $dbh->commit;
3165
3166   $main::lxdebug->leave_sub();
3167 }
3168
3169 sub get_history {
3170   $main::lxdebug->enter_sub();
3171
3172   my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3173   my ($orderBy, $desc) = split(/\-\-/, $order);
3174   $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3175   my @tempArray;
3176   my $i = 0;
3177   if ($trans_id ne "") {
3178     my $query =
3179       qq|SELECT h.employee_id, h.itime::timestamp(0) AS itime, h.addition, h.what_done, emp.name, h.snumbers, h.trans_id AS id | .
3180       qq|FROM history_erp h | .
3181       qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3182       qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3183       $order;
3184
3185     my $sth = $dbh->prepare($query) || $self->dberror($query);
3186
3187     $sth->execute() || $self->dberror("$query");
3188
3189     while(my $hash_ref = $sth->fetchrow_hashref()) {
3190       $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3191       $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3192       $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3193       $tempArray[$i++] = $hash_ref;
3194     }
3195     $main::lxdebug->leave_sub() and return \@tempArray
3196       if ($i > 0 && $tempArray[0] ne "");
3197   }
3198   $main::lxdebug->leave_sub();
3199   return 0;
3200 }
3201
3202 sub update_defaults {
3203   $main::lxdebug->enter_sub();
3204
3205   my ($self, $myconfig, $fld, $provided_dbh) = @_;
3206
3207   my $dbh;
3208   if ($provided_dbh) {
3209     $dbh = $provided_dbh;
3210   } else {
3211     $dbh = $self->dbconnect_noauto($myconfig);
3212   }
3213   my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3214   my $sth   = $dbh->prepare($query);
3215
3216   $sth->execute || $self->dberror($query);
3217   my ($var) = $sth->fetchrow_array;
3218   $sth->finish;
3219
3220   if ($var =~ m/\d+$/) {
3221     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3222     my $len_diff = length($var) - $-[0] - length($new_var);
3223     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3224
3225   } else {
3226     $var = $var . '1';
3227   }
3228
3229   $query = qq|UPDATE defaults SET $fld = ?|;
3230   do_query($self, $dbh, $query, $var);
3231
3232   if (!$provided_dbh) {
3233     $dbh->commit;
3234     $dbh->disconnect;
3235   }
3236
3237   $main::lxdebug->leave_sub();
3238
3239   return $var;
3240 }
3241
3242 sub update_business {
3243   $main::lxdebug->enter_sub();
3244
3245   my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3246
3247   my $dbh;
3248   if ($provided_dbh) {
3249     $dbh = $provided_dbh;
3250   } else {
3251     $dbh = $self->dbconnect_noauto($myconfig);
3252   }
3253   my $query =
3254     qq|SELECT customernumberinit FROM business
3255        WHERE id = ? FOR UPDATE|;
3256   my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3257
3258   return undef unless $var;
3259
3260   if ($var =~ m/\d+$/) {
3261     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3262     my $len_diff = length($var) - $-[0] - length($new_var);
3263     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3264
3265   } else {
3266     $var = $var . '1';
3267   }
3268
3269   $query = qq|UPDATE business
3270               SET customernumberinit = ?
3271               WHERE id = ?|;
3272   do_query($self, $dbh, $query, $var, $business_id);
3273
3274   if (!$provided_dbh) {
3275     $dbh->commit;
3276     $dbh->disconnect;
3277   }
3278
3279   $main::lxdebug->leave_sub();
3280
3281   return $var;
3282 }
3283
3284 sub get_partsgroup {
3285   $main::lxdebug->enter_sub();
3286
3287   my ($self, $myconfig, $p) = @_;
3288   my $target = $p->{target} || 'all_partsgroup';
3289
3290   my $dbh = $self->get_standard_dbh($myconfig);
3291
3292   my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3293                  FROM partsgroup pg
3294                  JOIN parts p ON (p.partsgroup_id = pg.id) |;
3295   my @values;
3296
3297   if ($p->{searchitems} eq 'part') {
3298     $query .= qq|WHERE p.inventory_accno_id > 0|;
3299   }
3300   if ($p->{searchitems} eq 'service') {
3301     $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3302   }
3303   if ($p->{searchitems} eq 'assembly') {
3304     $query .= qq|WHERE p.assembly = '1'|;
3305   }
3306   if ($p->{searchitems} eq 'labor') {
3307     $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3308   }
3309
3310   $query .= qq|ORDER BY partsgroup|;
3311
3312   if ($p->{all}) {
3313     $query = qq|SELECT id, partsgroup FROM partsgroup
3314                 ORDER BY partsgroup|;
3315   }
3316
3317   if ($p->{language_code}) {
3318     $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3319                   t.description AS translation
3320                 FROM partsgroup pg
3321                 JOIN parts p ON (p.partsgroup_id = pg.id)
3322                 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3323                 ORDER BY translation|;
3324     @values = ($p->{language_code});
3325   }
3326
3327   $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3328
3329   $main::lxdebug->leave_sub();
3330 }
3331
3332 sub get_pricegroup {
3333   $main::lxdebug->enter_sub();
3334
3335   my ($self, $myconfig, $p) = @_;
3336
3337   my $dbh = $self->get_standard_dbh($myconfig);
3338
3339   my $query = qq|SELECT p.id, p.pricegroup
3340                  FROM pricegroup p|;
3341
3342   $query .= qq| ORDER BY pricegroup|;
3343
3344   if ($p->{all}) {
3345     $query = qq|SELECT id, pricegroup FROM pricegroup
3346                 ORDER BY pricegroup|;
3347   }
3348
3349   $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3350
3351   $main::lxdebug->leave_sub();
3352 }
3353
3354 sub all_years {
3355 # usage $form->all_years($myconfig, [$dbh])
3356 # return list of all years where bookings found
3357 # (@all_years)
3358
3359   $main::lxdebug->enter_sub();
3360
3361   my ($self, $myconfig, $dbh) = @_;
3362
3363   $dbh ||= $self->get_standard_dbh($myconfig);
3364
3365   # get years
3366   my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3367                    (SELECT MAX(transdate) FROM acc_trans)|;
3368   my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3369
3370   if ($myconfig->{dateformat} =~ /^yy/) {
3371     ($startdate) = split /\W/, $startdate;
3372     ($enddate) = split /\W/, $enddate;
3373   } else {
3374     (@_) = split /\W/, $startdate;
3375     $startdate = $_[2];
3376     (@_) = split /\W/, $enddate;
3377     $enddate = $_[2];
3378   }
3379
3380   my @all_years;
3381   $startdate = substr($startdate,0,4);
3382   $enddate = substr($enddate,0,4);
3383
3384   while ($enddate >= $startdate) {
3385     push @all_years, $enddate--;
3386   }
3387
3388   return @all_years;
3389
3390   $main::lxdebug->leave_sub();
3391 }
3392
3393 sub backup_vars {
3394   $main::lxdebug->enter_sub();
3395   my $self = shift;
3396   my @vars = @_;
3397
3398   map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3399
3400   $main::lxdebug->leave_sub();
3401 }
3402
3403 sub restore_vars {
3404   $main::lxdebug->enter_sub();
3405
3406   my $self = shift;
3407   my @vars = @_;
3408
3409   map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3410
3411   $main::lxdebug->leave_sub();
3412 }
3413
3414 sub prepare_for_printing {
3415   my ($self) = @_;
3416
3417   $self->{templates} ||= $::myconfig{templates};
3418   $self->{formname}  ||= $self->{type};
3419   $self->{media}     ||= 'email';
3420
3421   die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3422
3423   # set shipto from billto unless set
3424   my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3425   if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3426     $self->{shiptoname}   = $::myconfig{company};
3427     $self->{shiptostreet} = $::myconfig{address};
3428   }
3429
3430   my $language = $self->{language} ? '_' . $self->{language} : '';
3431
3432   my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3433   if ($self->{language_id}) {
3434     ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3435   } else {
3436     $output_dateformat   = $::myconfig{dateformat};
3437     $output_numberformat = $::myconfig{numberformat};
3438     $output_longdates    = 1;
3439   }
3440
3441   # Retrieve accounts for tax calculation.
3442   IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3443
3444   if ($self->{type} =~ /_delivery_order$/) {
3445     DO->order_details();
3446   } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3447     OE->order_details(\%::myconfig, $self);
3448   } else {
3449     IS->invoice_details(\%::myconfig, $self, $::locale);
3450   }
3451
3452   # Chose extension & set source file name
3453   my $extension = 'html';
3454   if ($self->{format} eq 'postscript') {
3455     $self->{postscript}   = 1;
3456     $extension            = 'tex';
3457   } elsif ($self->{"format"} =~ /pdf/) {
3458     $self->{pdf}          = 1;
3459     $extension            = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3460   } elsif ($self->{"format"} =~ /opendocument/) {
3461     $self->{opendocument} = 1;
3462     $extension            = 'odt';
3463   } elsif ($self->{"format"} =~ /excel/) {
3464     $self->{excel}        = 1;
3465     $extension            = 'xls';
3466   }
3467
3468   my $printer_code    = $self->{printer_code} ? '_' . $self->{printer_code} : '';
3469   my $email_extension = -f "$::myconfig{templates}/$self->{formname}_email${language}.${extension}" ? '_email' : '';
3470   $self->{IN}         = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3471
3472   # Format dates.
3473   $self->format_dates($output_dateformat, $output_longdates,
3474                       qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3475                          transdate_oe deliverydate_oe employee_startdate employee_enddate),
3476                       grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3477
3478   $self->reformat_numbers($output_numberformat, 2,
3479                           qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3480                           grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3481
3482   $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3483
3484   my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3485
3486   if (scalar @{ $cvar_date_fields }) {
3487     $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3488   }
3489
3490   while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3491     $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3492   }
3493
3494   return $self;
3495 }
3496
3497 sub format_dates {
3498   my ($self, $dateformat, $longformat, @indices) = @_;
3499
3500   $dateformat ||= $::myconfig{dateformat};
3501
3502   foreach my $idx (@indices) {
3503     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3504       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3505         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3506       }
3507     }
3508
3509     next unless defined $self->{$idx};
3510
3511     if (!ref($self->{$idx})) {
3512       $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3513
3514     } elsif (ref($self->{$idx}) eq "ARRAY") {
3515       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3516         $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3517       }
3518     }
3519   }
3520 }
3521
3522 sub reformat_numbers {
3523   my ($self, $numberformat, $places, @indices) = @_;
3524
3525   return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3526
3527   foreach my $idx (@indices) {
3528     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3529       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3530         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3531       }
3532     }
3533
3534     next unless defined $self->{$idx};
3535
3536     if (!ref($self->{$idx})) {
3537       $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3538
3539     } elsif (ref($self->{$idx}) eq "ARRAY") {
3540       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3541         $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3542       }
3543     }
3544   }
3545
3546   my $saved_numberformat    = $::myconfig{numberformat};
3547   $::myconfig{numberformat} = $numberformat;
3548
3549   foreach my $idx (@indices) {
3550     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3551       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3552         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3553       }
3554     }
3555
3556     next unless defined $self->{$idx};
3557
3558     if (!ref($self->{$idx})) {
3559       $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3560
3561     } elsif (ref($self->{$idx}) eq "ARRAY") {
3562       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3563         $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3564       }
3565     }
3566   }
3567
3568   $::myconfig{numberformat} = $saved_numberformat;
3569 }
3570
3571 1;
3572
3573 __END__
3574
3575 =head1 NAME
3576
3577 SL::Form.pm - main data object.
3578
3579 =head1 SYNOPSIS
3580
3581 This is the main data object of Lx-Office.
3582 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3583 Points of interest for a beginner are:
3584
3585  - $form->error            - renders a generic error in html. accepts an error message
3586  - $form->get_standard_dbh - returns a database connection for the
3587
3588 =head1 SPECIAL FUNCTIONS
3589
3590 =head2 C<update_business> PARAMS
3591
3592 PARAMS (not named):
3593  \%config,     - config hashref
3594  $business_id, - business id
3595  $dbh          - optional database handle
3596
3597 handles business (thats customer/vendor types) sequences.
3598
3599 special behaviour for empty strings in customerinitnumber field:
3600 will in this case not increase the value, and return undef.
3601
3602 =head2 C<redirect_header> $url
3603
3604 Generates a HTTP redirection header for the new C<$url>. Constructs an
3605 absolute URL including scheme, host name and port. If C<$url> is a
3606 relative URL then it is considered relative to Lx-Office base URL.
3607
3608 This function C<die>s if headers have already been created with
3609 C<$::form-E<gt>header>.
3610
3611 Examples:
3612
3613   print $::form->redirect_header('oe.pl?action=edit&id=1234');
3614   print $::form->redirect_header('http://www.lx-office.org/');
3615
3616 =head2 C<header>
3617
3618 Generates a general purpose http/html header and includes most of the scripts
3619 and stylesheets needed. Stylesheets can be added with L<use_stylesheet>.
3620
3621 Only one header will be generated. If the method was already called in this
3622 request it will not output anything and return undef. Also if no
3623 HTTP_USER_AGENT is found, no header is generated.
3624
3625 Although header does not accept parameters itself, it will honor special
3626 hashkeys of its Form instance:
3627
3628 =over 4
3629
3630 =item refresh_time
3631
3632 =item refresh_url
3633
3634 If one of these is set, a http-equiv refresh is generated. Missing parameters
3635 default to 3 seconds and the refering url.
3636
3637 =item stylesheet
3638
3639 Either a scalar or an array ref. Will be inlined into the header. Add
3640 stylesheets with the L<use_stylesheet> function.
3641
3642 =item landscape
3643
3644 If true, a css snippet will be generated that sets the page in landscape mode.
3645
3646 =item favicon
3647
3648 Used to override the default favicon.
3649
3650 =item title
3651
3652 A html page title will be generated from this
3653
3654 =back
3655
3656 =cut