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