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