SL/Form.pm

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