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