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