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