SL/Form.pm

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