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