SL/Form.pm

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