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