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