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