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