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