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