SL/Form.pm

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