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