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