SL/Form.pm

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