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