SL/Form.pm

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