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