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