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