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