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   my @currencies =();
1649
1650   my $query = qq|SELECT name FROM currencies|;
1651   my @currencies = map { $_->{name} } selectall_hashref_query($self, $dbh, $query);
1652
1653   $main::lxdebug->leave_sub();
1654
1655   return @currencies;
1656 }
1657
1658 sub get_default_currency {
1659   $main::lxdebug->enter_sub();
1660
1661   my ($self, $myconfig) = @_;
1662   my $dbh      = $self->get_standard_dbh($myconfig);
1663   my $query = qq|SELECT name AS curr FROM currencies WHERE id = (SELECT currency_id FROM defaults)|;
1664
1665   my ($defaultcurrency) = selectrow_query($self, $dbh, $query);
1666
1667   $main::lxdebug->leave_sub();
1668
1669   return $defaultcurrency;
1670 }
1671
1672 sub set_payment_options {
1673   $main::lxdebug->enter_sub();
1674
1675   my ($self, $myconfig, $transdate) = @_;
1676
1677   return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1678
1679   my $dbh = $self->get_standard_dbh($myconfig);
1680
1681   my $query =
1682     qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long , p.description | .
1683     qq|FROM payment_terms p | .
1684     qq|WHERE p.id = ?|;
1685
1686   ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1687    $self->{payment_terms}, $self->{payment_description}) =
1688      selectrow_query($self, $dbh, $query, $self->{payment_id});
1689
1690   if ($transdate eq "") {
1691     if ($self->{invdate}) {
1692       $transdate = $self->{invdate};
1693     } else {
1694       $transdate = $self->{transdate};
1695     }
1696   }
1697
1698   $query =
1699     qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1700     qq|FROM payment_terms|;
1701   ($self->{netto_date}, $self->{skonto_date}) =
1702     selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1703
1704   my ($invtotal, $total);
1705   my (%amounts, %formatted_amounts);
1706
1707   if ($self->{type} =~ /_order$/) {
1708     $amounts{invtotal} = $self->{ordtotal};
1709     $amounts{total}    = $self->{ordtotal};
1710
1711   } elsif ($self->{type} =~ /_quotation$/) {
1712     $amounts{invtotal} = $self->{quototal};
1713     $amounts{total}    = $self->{quototal};
1714
1715   } else {
1716     $amounts{invtotal} = $self->{invtotal};
1717     $amounts{total}    = $self->{total};
1718   }
1719   map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1720
1721   $amounts{skonto_in_percent}  = 100.0 * $self->{percent_skonto};
1722   $amounts{skonto_amount}      = $amounts{invtotal} * $self->{percent_skonto};
1723   $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1724   $amounts{total_wo_skonto}    = $amounts{total}    * (1 - $self->{percent_skonto});
1725
1726   foreach (keys %amounts) {
1727     $amounts{$_}           = $self->round_amount($amounts{$_}, 2);
1728     $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1729   }
1730
1731   if ($self->{"language_id"}) {
1732     $query =
1733       qq|SELECT t.translation, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1734       qq|FROM generic_translations t | .
1735       qq|LEFT JOIN language l ON t.language_id = l.id | .
1736       qq|WHERE (t.language_id = ?)
1737            AND (t.translation_id = ?)
1738            AND (t.translation_type = 'SL::DB::PaymentTerm/description_long')|;
1739     my ($description_long, $output_numberformat, $output_dateformat,
1740       $output_longdates) =
1741       selectrow_query($self, $dbh, $query,
1742                       $self->{"language_id"}, $self->{"payment_id"});
1743
1744     $self->{payment_terms} = $description_long if ($description_long);
1745
1746     if ($output_dateformat) {
1747       foreach my $key (qw(netto_date skonto_date)) {
1748         $self->{$key} =
1749           $main::locale->reformat_date($myconfig, $self->{$key},
1750                                        $output_dateformat,
1751                                        $output_longdates);
1752       }
1753     }
1754
1755     if ($output_numberformat &&
1756         ($output_numberformat ne $myconfig->{"numberformat"})) {
1757       my $saved_numberformat = $myconfig->{"numberformat"};
1758       $myconfig->{"numberformat"} = $output_numberformat;
1759       map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1760       $myconfig->{"numberformat"} = $saved_numberformat;
1761     }
1762   }
1763
1764   $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1765   $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1766   $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1767   $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1768   $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1769   $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1770   $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1771
1772   map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1773
1774   $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1775
1776   $main::lxdebug->leave_sub();
1777
1778 }
1779
1780 sub get_template_language {
1781   $main::lxdebug->enter_sub();
1782
1783   my ($self, $myconfig) = @_;
1784
1785   my $template_code = "";
1786
1787   if ($self->{language_id}) {
1788     my $dbh = $self->get_standard_dbh($myconfig);
1789     my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1790     ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1791   }
1792
1793   $main::lxdebug->leave_sub();
1794
1795   return $template_code;
1796 }
1797
1798 sub get_printer_code {
1799   $main::lxdebug->enter_sub();
1800
1801   my ($self, $myconfig) = @_;
1802
1803   my $template_code = "";
1804
1805   if ($self->{printer_id}) {
1806     my $dbh = $self->get_standard_dbh($myconfig);
1807     my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1808     ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1809   }
1810
1811   $main::lxdebug->leave_sub();
1812
1813   return $template_code;
1814 }
1815
1816 sub get_shipto {
1817   $main::lxdebug->enter_sub();
1818
1819   my ($self, $myconfig) = @_;
1820
1821   my $template_code = "";
1822
1823   if ($self->{shipto_id}) {
1824     my $dbh = $self->get_standard_dbh($myconfig);
1825     my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1826     my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1827     map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1828   }
1829
1830   $main::lxdebug->leave_sub();
1831 }
1832
1833 sub add_shipto {
1834   $main::lxdebug->enter_sub();
1835
1836   my ($self, $dbh, $id, $module) = @_;
1837
1838   my $shipto;
1839   my @values;
1840
1841   foreach my $item (qw(name department_1 department_2 street zipcode city country
1842                        contact cp_gender phone fax email)) {
1843     if ($self->{"shipto$item"}) {
1844       $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1845     }
1846     push(@values, $self->{"shipto${item}"});
1847   }
1848
1849   if ($shipto) {
1850     if ($self->{shipto_id}) {
1851       my $query = qq|UPDATE shipto set
1852                        shiptoname = ?,
1853                        shiptodepartment_1 = ?,
1854                        shiptodepartment_2 = ?,
1855                        shiptostreet = ?,
1856                        shiptozipcode = ?,
1857                        shiptocity = ?,
1858                        shiptocountry = ?,
1859                        shiptocontact = ?,
1860                        shiptocp_gender = ?,
1861                        shiptophone = ?,
1862                        shiptofax = ?,
1863                        shiptoemail = ?
1864                      WHERE shipto_id = ?|;
1865       do_query($self, $dbh, $query, @values, $self->{shipto_id});
1866     } else {
1867       my $query = qq|SELECT * FROM shipto
1868                      WHERE shiptoname = ? AND
1869                        shiptodepartment_1 = ? AND
1870                        shiptodepartment_2 = ? AND
1871                        shiptostreet = ? AND
1872                        shiptozipcode = ? AND
1873                        shiptocity = ? AND
1874                        shiptocountry = ? AND
1875                        shiptocontact = ? AND
1876                        shiptocp_gender = ? AND
1877                        shiptophone = ? AND
1878                        shiptofax = ? AND
1879                        shiptoemail = ? AND
1880                        module = ? AND
1881                        trans_id = ?|;
1882       my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
1883       if(!$insert_check){
1884         $query =
1885           qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
1886                                  shiptostreet, shiptozipcode, shiptocity, shiptocountry,
1887                                  shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
1888              VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
1889         do_query($self, $dbh, $query, $id, @values, $module);
1890       }
1891     }
1892   }
1893
1894   $main::lxdebug->leave_sub();
1895 }
1896
1897 sub get_employee {
1898   $main::lxdebug->enter_sub();
1899
1900   my ($self, $dbh) = @_;
1901
1902   $dbh ||= $self->get_standard_dbh(\%main::myconfig);
1903
1904   my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
1905   ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
1906   $self->{"employee_id"} *= 1;
1907
1908   $main::lxdebug->leave_sub();
1909 }
1910
1911 sub get_employee_data {
1912   $main::lxdebug->enter_sub();
1913
1914   my $self     = shift;
1915   my %params   = @_;
1916
1917   Common::check_params(\%params, qw(prefix));
1918   Common::check_params_x(\%params, qw(id));
1919
1920   if (!$params{id}) {
1921     $main::lxdebug->leave_sub();
1922     return;
1923   }
1924
1925   my $myconfig = \%main::myconfig;
1926   my $dbh      = $params{dbh} || $self->get_standard_dbh($myconfig);
1927
1928   my ($login)  = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
1929
1930   if ($login) {
1931     my $user = User->new(login => $login);
1932     map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
1933
1934     $self->{$params{prefix} . '_login'}   = $login;
1935     $self->{$params{prefix} . '_name'}  ||= $login;
1936   }
1937
1938   $main::lxdebug->leave_sub();
1939 }
1940
1941 sub get_duedate {
1942   $main::lxdebug->enter_sub();
1943
1944   my ($self, $myconfig, $reference_date) = @_;
1945
1946   $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
1947
1948   my $dbh         = $self->get_standard_dbh($myconfig);
1949   my ($payment_id, $duedate);
1950
1951   if($self->{payment_id}) {
1952     $payment_id = $self->{payment_id};
1953   } elsif($self->{vendor_id}) {
1954     my $query = 'SELECT payment_id FROM vendor WHERE id = ?';
1955     ($payment_id) = selectrow_query($self, $dbh, $query, $self->{vendor_id});
1956   }
1957
1958   if ($payment_id) {
1959     my $query  = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
1960     ($duedate) = selectrow_query($self, $dbh, $query, $payment_id);
1961   }
1962
1963   $main::lxdebug->leave_sub();
1964
1965   return $duedate;
1966 }
1967
1968 sub _get_contacts {
1969   $main::lxdebug->enter_sub();
1970
1971   my ($self, $dbh, $id, $key) = @_;
1972
1973   $key = "all_contacts" unless ($key);
1974
1975   if (!$id) {
1976     $self->{$key} = [];
1977     $main::lxdebug->leave_sub();
1978     return;
1979   }
1980
1981   my $query =
1982     qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
1983     qq|FROM contacts | .
1984     qq|WHERE cp_cv_id = ? | .
1985     qq|ORDER BY lower(cp_name)|;
1986
1987   $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
1988
1989   $main::lxdebug->leave_sub();
1990 }
1991
1992 sub _get_projects {
1993   $main::lxdebug->enter_sub();
1994
1995   my ($self, $dbh, $key) = @_;
1996
1997   my ($all, $old_id, $where, @values);
1998
1999   if (ref($key) eq "HASH") {
2000     my $params = $key;
2001
2002     $key = "ALL_PROJECTS";
2003
2004     foreach my $p (keys(%{$params})) {
2005       if ($p eq "all") {
2006         $all = $params->{$p};
2007       } elsif ($p eq "old_id") {
2008         $old_id = $params->{$p};
2009       } elsif ($p eq "key") {
2010         $key = $params->{$p};
2011       }
2012     }
2013   }
2014
2015   if (!$all) {
2016     $where = "WHERE active ";
2017     if ($old_id) {
2018       if (ref($old_id) eq "ARRAY") {
2019         my @ids = grep({ $_ } @{$old_id});
2020         if (@ids) {
2021           $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2022           push(@values, @ids);
2023         }
2024       } else {
2025         $where .= " OR (id = ?) ";
2026         push(@values, $old_id);
2027       }
2028     }
2029   }
2030
2031   my $query =
2032     qq|SELECT id, projectnumber, description, active | .
2033     qq|FROM project | .
2034     $where .
2035     qq|ORDER BY lower(projectnumber)|;
2036
2037   $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2038
2039   $main::lxdebug->leave_sub();
2040 }
2041
2042 sub _get_shipto {
2043   $main::lxdebug->enter_sub();
2044
2045   my ($self, $dbh, $vc_id, $key) = @_;
2046
2047   $key = "all_shipto" unless ($key);
2048
2049   if ($vc_id) {
2050     # get shipping addresses
2051     my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2052
2053     $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2054
2055   } else {
2056     $self->{$key} = [];
2057   }
2058
2059   $main::lxdebug->leave_sub();
2060 }
2061
2062 sub _get_printers {
2063   $main::lxdebug->enter_sub();
2064
2065   my ($self, $dbh, $key) = @_;
2066
2067   $key = "all_printers" unless ($key);
2068
2069   my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2070
2071   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2072
2073   $main::lxdebug->leave_sub();
2074 }
2075
2076 sub _get_charts {
2077   $main::lxdebug->enter_sub();
2078
2079   my ($self, $dbh, $params) = @_;
2080   my ($key);
2081
2082   $key = $params->{key};
2083   $key = "all_charts" unless ($key);
2084
2085   my $transdate = quote_db_date($params->{transdate});
2086
2087   my $query =
2088     qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2089     qq|FROM chart c | .
2090     qq|LEFT JOIN taxkeys tk ON | .
2091     qq|(tk.id = (SELECT id FROM taxkeys | .
2092     qq|          WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2093     qq|          ORDER BY startdate DESC LIMIT 1)) | .
2094     qq|ORDER BY c.accno|;
2095
2096   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2097
2098   $main::lxdebug->leave_sub();
2099 }
2100
2101 sub _get_taxcharts {
2102   $main::lxdebug->enter_sub();
2103
2104   my ($self, $dbh, $params) = @_;
2105
2106   my $key = "all_taxcharts";
2107   my @where;
2108
2109   if (ref $params eq 'HASH') {
2110     $key = $params->{key} if ($params->{key});
2111     if ($params->{module} eq 'AR') {
2112       push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2113
2114     } elsif ($params->{module} eq 'AP') {
2115       push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2116     }
2117
2118   } elsif ($params) {
2119     $key = $params;
2120   }
2121
2122   my $where = @where ? ' WHERE ' . join(' AND ', map { "($_)" } @where) : '';
2123
2124   my $query = qq|SELECT * FROM tax $where ORDER BY taxkey, rate|;
2125
2126   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2127
2128   $main::lxdebug->leave_sub();
2129 }
2130
2131 sub _get_taxzones {
2132   $main::lxdebug->enter_sub();
2133
2134   my ($self, $dbh, $key) = @_;
2135
2136   $key = "all_taxzones" unless ($key);
2137
2138   my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2139
2140   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2141
2142   $main::lxdebug->leave_sub();
2143 }
2144
2145 sub _get_employees {
2146   $main::lxdebug->enter_sub();
2147
2148   my ($self, $dbh, $default_key, $key) = @_;
2149
2150   $key = $default_key unless ($key);
2151   $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2152
2153   $main::lxdebug->leave_sub();
2154 }
2155
2156 sub _get_business_types {
2157   $main::lxdebug->enter_sub();
2158
2159   my ($self, $dbh, $key) = @_;
2160
2161   my $options       = ref $key eq 'HASH' ? $key : { key => $key };
2162   $options->{key} ||= "all_business_types";
2163   my $where         = '';
2164
2165   if (exists $options->{salesman}) {
2166     $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2167   }
2168
2169   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2170
2171   $main::lxdebug->leave_sub();
2172 }
2173
2174 sub _get_languages {
2175   $main::lxdebug->enter_sub();
2176
2177   my ($self, $dbh, $key) = @_;
2178
2179   $key = "all_languages" unless ($key);
2180
2181   my $query = qq|SELECT * FROM language ORDER BY id|;
2182
2183   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2184
2185   $main::lxdebug->leave_sub();
2186 }
2187
2188 sub _get_dunning_configs {
2189   $main::lxdebug->enter_sub();
2190
2191   my ($self, $dbh, $key) = @_;
2192
2193   $key = "all_dunning_configs" unless ($key);
2194
2195   my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2196
2197   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2198
2199   $main::lxdebug->leave_sub();
2200 }
2201
2202 sub _get_currencies {
2203 $main::lxdebug->enter_sub();
2204
2205   my ($self, $dbh, $key) = @_;
2206
2207   $key = "all_currencies" unless ($key);
2208
2209   $self->{$key} = [$self->get_all_currencies()];
2210
2211   $main::lxdebug->leave_sub();
2212 }
2213
2214 sub _get_payments {
2215 $main::lxdebug->enter_sub();
2216
2217   my ($self, $dbh, $key) = @_;
2218
2219   $key = "all_payments" unless ($key);
2220
2221   my $query = qq|SELECT * FROM payment_terms ORDER BY sortkey|;
2222
2223   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2224
2225   $main::lxdebug->leave_sub();
2226 }
2227
2228 sub _get_customers {
2229   $main::lxdebug->enter_sub();
2230
2231   my ($self, $dbh, $key) = @_;
2232
2233   my $options        = ref $key eq 'HASH' ? $key : { key => $key };
2234   $options->{key}  ||= "all_customers";
2235   my $limit_clause   = $options->{limit} ? "LIMIT $options->{limit}" : '';
2236
2237   my @where;
2238   push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if  $options->{business_is_salesman};
2239   push @where, qq|NOT obsolete|                                            if !$options->{with_obsolete};
2240   my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2241
2242   my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2243   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2244
2245   $main::lxdebug->leave_sub();
2246 }
2247
2248 sub _get_vendors {
2249   $main::lxdebug->enter_sub();
2250
2251   my ($self, $dbh, $key) = @_;
2252
2253   $key = "all_vendors" unless ($key);
2254
2255   my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2256
2257   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2258
2259   $main::lxdebug->leave_sub();
2260 }
2261
2262 sub _get_departments {
2263   $main::lxdebug->enter_sub();
2264
2265   my ($self, $dbh, $key) = @_;
2266
2267   $key = "all_departments" unless ($key);
2268
2269   my $query = qq|SELECT * FROM department ORDER BY description|;
2270
2271   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2272
2273   $main::lxdebug->leave_sub();
2274 }
2275
2276 sub _get_warehouses {
2277   $main::lxdebug->enter_sub();
2278
2279   my ($self, $dbh, $param) = @_;
2280
2281   my ($key, $bins_key);
2282
2283   if ('' eq ref $param) {
2284     $key = $param;
2285
2286   } else {
2287     $key      = $param->{key};
2288     $bins_key = $param->{bins};
2289   }
2290
2291   my $query = qq|SELECT w.* FROM warehouse w
2292                  WHERE (NOT w.invalid) AND
2293                    ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2294                  ORDER BY w.sortkey|;
2295
2296   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2297
2298   if ($bins_key) {
2299     $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?
2300                 ORDER BY description|;
2301     my $sth = prepare_query($self, $dbh, $query);
2302
2303     foreach my $warehouse (@{ $self->{$key} }) {
2304       do_statement($self, $sth, $query, $warehouse->{id});
2305       $warehouse->{$bins_key} = [];
2306
2307       while (my $ref = $sth->fetchrow_hashref()) {
2308         push @{ $warehouse->{$bins_key} }, $ref;
2309       }
2310     }
2311     $sth->finish();
2312   }
2313
2314   $main::lxdebug->leave_sub();
2315 }
2316
2317 sub _get_simple {
2318   $main::lxdebug->enter_sub();
2319
2320   my ($self, $dbh, $table, $key, $sortkey) = @_;
2321
2322   my $query  = qq|SELECT * FROM $table|;
2323   $query    .= qq| ORDER BY $sortkey| if ($sortkey);
2324
2325   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2326
2327   $main::lxdebug->leave_sub();
2328 }
2329
2330 #sub _get_groups {
2331 #  $main::lxdebug->enter_sub();
2332 #
2333 #  my ($self, $dbh, $key) = @_;
2334 #
2335 #  $key ||= "all_groups";
2336 #
2337 #  my $groups = $main::auth->read_groups();
2338 #
2339 #  $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2340 #
2341 #  $main::lxdebug->leave_sub();
2342 #}
2343
2344 sub get_lists {
2345   $main::lxdebug->enter_sub();
2346
2347   my $self = shift;
2348   my %params = @_;
2349
2350   my $dbh = $self->get_standard_dbh(\%main::myconfig);
2351   my ($sth, $query, $ref);
2352
2353   my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2354   my $vc_id = $self->{"${vc}_id"};
2355
2356   if ($params{"contacts"}) {
2357     $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2358   }
2359
2360   if ($params{"shipto"}) {
2361     $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2362   }
2363
2364   if ($params{"projects"} || $params{"all_projects"}) {
2365     $self->_get_projects($dbh, $params{"all_projects"} ?
2366                          $params{"all_projects"} : $params{"projects"},
2367                          $params{"all_projects"} ? 1 : 0);
2368   }
2369
2370   if ($params{"printers"}) {
2371     $self->_get_printers($dbh, $params{"printers"});
2372   }
2373
2374   if ($params{"languages"}) {
2375     $self->_get_languages($dbh, $params{"languages"});
2376   }
2377
2378   if ($params{"charts"}) {
2379     $self->_get_charts($dbh, $params{"charts"});
2380   }
2381
2382   if ($params{"taxcharts"}) {
2383     $self->_get_taxcharts($dbh, $params{"taxcharts"});
2384   }
2385
2386   if ($params{"taxzones"}) {
2387     $self->_get_taxzones($dbh, $params{"taxzones"});
2388   }
2389
2390   if ($params{"employees"}) {
2391     $self->_get_employees($dbh, "all_employees", $params{"employees"});
2392   }
2393
2394   if ($params{"salesmen"}) {
2395     $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2396   }
2397
2398   if ($params{"business_types"}) {
2399     $self->_get_business_types($dbh, $params{"business_types"});
2400   }
2401
2402   if ($params{"dunning_configs"}) {
2403     $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2404   }
2405
2406   if($params{"currencies"}) {
2407     $self->_get_currencies($dbh, $params{"currencies"});
2408   }
2409
2410   if($params{"customers"}) {
2411     $self->_get_customers($dbh, $params{"customers"});
2412   }
2413
2414   if($params{"vendors"}) {
2415     if (ref $params{"vendors"} eq 'HASH') {
2416       $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2417     } else {
2418       $self->_get_vendors($dbh, $params{"vendors"});
2419     }
2420   }
2421
2422   if($params{"payments"}) {
2423     $self->_get_payments($dbh, $params{"payments"});
2424   }
2425
2426   if($params{"departments"}) {
2427     $self->_get_departments($dbh, $params{"departments"});
2428   }
2429
2430   if ($params{price_factors}) {
2431     $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2432   }
2433
2434   if ($params{warehouses}) {
2435     $self->_get_warehouses($dbh, $params{warehouses});
2436   }
2437
2438 #  if ($params{groups}) {
2439 #    $self->_get_groups($dbh, $params{groups});
2440 #  }
2441
2442   if ($params{partsgroup}) {
2443     $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2444   }
2445
2446   $main::lxdebug->leave_sub();
2447 }
2448
2449 # this sub gets the id and name from $table
2450 sub get_name {
2451   $main::lxdebug->enter_sub();
2452
2453   my ($self, $myconfig, $table) = @_;
2454
2455   # connect to database
2456   my $dbh = $self->get_standard_dbh($myconfig);
2457
2458   $table = $table eq "customer" ? "customer" : "vendor";
2459   my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2460
2461   my ($query, @values);
2462
2463   if (!$self->{openinvoices}) {
2464     my $where;
2465     if ($self->{customernumber} ne "") {
2466       $where = qq|(vc.customernumber ILIKE ?)|;
2467       push(@values, '%' . $self->{customernumber} . '%');
2468     } else {
2469       $where = qq|(vc.name ILIKE ?)|;
2470       push(@values, '%' . $self->{$table} . '%');
2471     }
2472
2473     $query =
2474       qq~SELECT vc.id, vc.name,
2475            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2476          FROM $table vc
2477          WHERE $where AND (NOT vc.obsolete)
2478          ORDER BY vc.name~;
2479   } else {
2480     $query =
2481       qq~SELECT DISTINCT vc.id, vc.name,
2482            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2483          FROM $arap a
2484          JOIN $table vc ON (a.${table}_id = vc.id)
2485          WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2486          ORDER BY vc.name~;
2487     push(@values, '%' . $self->{$table} . '%');
2488   }
2489
2490   $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2491
2492   $main::lxdebug->leave_sub();
2493
2494   return scalar(@{ $self->{name_list} });
2495 }
2496
2497 # the selection sub is used in the AR, AP, IS, IR, DO and OE module
2498 #
2499 sub all_vc {
2500   $main::lxdebug->enter_sub();
2501
2502   my ($self, $myconfig, $table, $module) = @_;
2503
2504   my $ref;
2505   my $dbh = $self->get_standard_dbh;
2506
2507   $table = $table eq "customer" ? "customer" : "vendor";
2508
2509   # build selection list
2510   # Hotfix für Bug 1837 - Besser wäre es alte Buchungsbelege
2511   # OHNE Auswahlliste (reines Textfeld) zu laden. Hilft aber auch
2512   # nicht für veränderbare Belege (oe, do, ...)
2513   my $obsolete = $self->{id} ? '' : "WHERE NOT obsolete";
2514   my $query = qq|SELECT count(*) FROM $table $obsolete|;
2515   my ($count) = selectrow_query($self, $dbh, $query);
2516
2517   if ($count <= $myconfig->{vclimit}) {
2518     $query = qq|SELECT id, name, salesman_id
2519                 FROM $table $obsolete
2520                 ORDER BY name|;
2521     $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2522   }
2523
2524   # get self
2525   $self->get_employee($dbh);
2526
2527   # setup sales contacts
2528   $query = qq|SELECT e.id, e.name
2529               FROM employee e
2530               WHERE (e.sales = '1') AND (NOT e.id = ?)
2531               ORDER BY name|;
2532   $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2533
2534   # this is for self
2535   push(@{ $self->{all_employees} },
2536        { id   => $self->{employee_id},
2537          name => $self->{employee} });
2538
2539     # prepare query for departments
2540     $query = qq|SELECT id, description
2541                 FROM department
2542                 ORDER BY description|;
2543
2544   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2545
2546   # get languages
2547   $query = qq|SELECT id, description
2548               FROM language
2549               ORDER BY id|;
2550
2551   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2552
2553   # get printer
2554   $query = qq|SELECT printer_description, id
2555               FROM printers
2556               ORDER BY printer_description|;
2557
2558   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2559
2560   # get payment terms
2561   $query = qq|SELECT id, description
2562               FROM payment_terms
2563               ORDER BY sortkey|;
2564
2565   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2566
2567   $main::lxdebug->leave_sub();
2568 }
2569
2570 sub language_payment {
2571   $main::lxdebug->enter_sub();
2572
2573   my ($self, $myconfig) = @_;
2574
2575   my $dbh = $self->get_standard_dbh($myconfig);
2576   # get languages
2577   my $query = qq|SELECT id, description
2578                  FROM language
2579                  ORDER BY id|;
2580
2581   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2582
2583   # get printer
2584   $query = qq|SELECT printer_description, id
2585               FROM printers
2586               ORDER BY printer_description|;
2587
2588   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2589
2590   # get payment terms
2591   $query = qq|SELECT id, description
2592               FROM payment_terms
2593               ORDER BY sortkey|;
2594
2595   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2596
2597   # get buchungsgruppen
2598   $query = qq|SELECT id, description
2599               FROM buchungsgruppen|;
2600
2601   $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2602
2603   $main::lxdebug->leave_sub();
2604 }
2605
2606 # this is only used for reports
2607 sub all_departments {
2608   $main::lxdebug->enter_sub();
2609
2610   my ($self, $myconfig, $table) = @_;
2611
2612   my $dbh = $self->get_standard_dbh($myconfig);
2613
2614   my $query = qq|SELECT id, description
2615                  FROM department
2616                  ORDER BY description|;
2617   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2618
2619   delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2620
2621   $main::lxdebug->leave_sub();
2622 }
2623
2624 sub create_links {
2625   $main::lxdebug->enter_sub();
2626
2627   my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2628
2629   my ($fld, $arap);
2630   if ($table eq "customer") {
2631     $fld = "buy";
2632     $arap = "ar";
2633   } else {
2634     $table = "vendor";
2635     $fld = "sell";
2636     $arap = "ap";
2637   }
2638
2639   $self->all_vc($myconfig, $table, $module);
2640
2641   # get last customers or vendors
2642   my ($query, $sth, $ref);
2643
2644   my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2645   my %xkeyref = ();
2646
2647   if (!$self->{id}) {
2648
2649     my $transdate = "current_date";
2650     if ($self->{transdate}) {
2651       $transdate = $dbh->quote($self->{transdate});
2652     }
2653
2654     # now get the account numbers
2655 #    $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2656 #                FROM chart c, taxkeys tk
2657 #                WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2658 #                  (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2659 #                ORDER BY c.accno|;
2660
2661 #  same query as above, but without expensive subquery for each row. about 80% faster
2662     $query = qq|
2663       SELECT c.accno, c.description, c.link, c.taxkey_id, tk2.tax_id
2664         FROM chart c
2665         -- find newest entries in taxkeys
2666         INNER JOIN (
2667           SELECT chart_id, MAX(startdate) AS startdate
2668           FROM taxkeys
2669           WHERE (startdate <= $transdate)
2670           GROUP BY chart_id
2671         ) tk ON (c.id = tk.chart_id)
2672         -- and load all of those entries
2673         INNER JOIN taxkeys tk2
2674            ON (tk.chart_id = tk2.chart_id AND tk.startdate = tk2.startdate)
2675        WHERE (c.link LIKE ?)
2676       ORDER BY c.accno|;
2677
2678     $sth = $dbh->prepare($query);
2679
2680     do_statement($self, $sth, $query, '%' . $module . '%');
2681
2682     $self->{accounts} = "";
2683     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2684
2685       foreach my $key (split(/:/, $ref->{link})) {
2686         if ($key =~ /\Q$module\E/) {
2687
2688           # cross reference for keys
2689           $xkeyref{ $ref->{accno} } = $key;
2690
2691           push @{ $self->{"${module}_links"}{$key} },
2692             { accno       => $ref->{accno},
2693               description => $ref->{description},
2694               taxkey      => $ref->{taxkey_id},
2695               tax_id      => $ref->{tax_id} };
2696
2697           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2698         }
2699       }
2700     }
2701   }
2702
2703   # get taxkeys and description
2704   $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2705   $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2706
2707   if (($module eq "AP") || ($module eq "AR")) {
2708     # get tax rates and description
2709     $query = qq|SELECT * FROM tax|;
2710     $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2711   }
2712
2713   my $extra_columns = '';
2714   $extra_columns   .= 'a.direct_debit, ' if ($module eq 'AR') || ($module eq 'AP');
2715
2716   if ($self->{id}) {
2717     $query =
2718       qq|SELECT
2719            a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2720            a.duedate, a.ordnumber, a.taxincluded, (SELECT cu.name FROM currencies cu WHERE cu.id=a.currency_id) AS currency, a.notes,
2721            a.intnotes, a.department_id, a.amount AS oldinvtotal,
2722            a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2723            a.globalproject_id, ${extra_columns}
2724            c.name AS $table,
2725            d.description AS department,
2726            e.name AS employee
2727          FROM $arap a
2728          JOIN $table c ON (a.${table}_id = c.id)
2729          LEFT JOIN employee e ON (e.id = a.employee_id)
2730          LEFT JOIN department d ON (d.id = a.department_id)
2731          WHERE a.id = ?|;
2732     $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2733
2734     foreach my $key (keys %$ref) {
2735       $self->{$key} = $ref->{$key};
2736     }
2737
2738     my $transdate = "current_date";
2739     if ($self->{transdate}) {
2740       $transdate = $dbh->quote($self->{transdate});
2741     }
2742
2743     # now get the account numbers
2744     $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2745                 FROM chart c
2746                 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2747                 WHERE c.link LIKE ?
2748                   AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2749                     OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2750                 ORDER BY c.accno|;
2751
2752     $sth = $dbh->prepare($query);
2753     do_statement($self, $sth, $query, "%$module%");
2754
2755     $self->{accounts} = "";
2756     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2757
2758       foreach my $key (split(/:/, $ref->{link})) {
2759         if ($key =~ /\Q$module\E/) {
2760
2761           # cross reference for keys
2762           $xkeyref{ $ref->{accno} } = $key;
2763
2764           push @{ $self->{"${module}_links"}{$key} },
2765             { accno       => $ref->{accno},
2766               description => $ref->{description},
2767               taxkey      => $ref->{taxkey_id},
2768               tax_id      => $ref->{tax_id} };
2769
2770           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2771         }
2772       }
2773     }
2774
2775
2776     # get amounts from individual entries
2777     $query =
2778       qq|SELECT
2779            c.accno, c.description,
2780            a.acc_trans_id, a.source, a.amount, a.memo, a.transdate, a.gldate, a.cleared, a.project_id, a.taxkey,
2781            p.projectnumber,
2782            t.rate, t.id
2783          FROM acc_trans a
2784          LEFT JOIN chart c ON (c.id = a.chart_id)
2785          LEFT JOIN project p ON (p.id = a.project_id)
2786          LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2787                                     WHERE (tk.taxkey_id=a.taxkey) AND
2788                                       ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2789                                         THEN tk.chart_id = a.chart_id
2790                                         ELSE 1 = 1
2791                                         END)
2792                                        OR (c.link='%tax%')) AND
2793                                       (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2794          WHERE a.trans_id = ?
2795          AND a.fx_transaction = '0'
2796          ORDER BY a.acc_trans_id, a.transdate|;
2797     $sth = $dbh->prepare($query);
2798     do_statement($self, $sth, $query, $self->{id});
2799
2800     # get exchangerate for currency
2801     $self->{exchangerate} =
2802       $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2803     my $index = 0;
2804
2805     # store amounts in {acc_trans}{$key} for multiple accounts
2806     while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2807       $ref->{exchangerate} =
2808         $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2809       if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2810         $index++;
2811       }
2812       if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2813         $ref->{amount} *= -1;
2814       }
2815       $ref->{index} = $index;
2816
2817       push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2818     }
2819
2820     $sth->finish;
2821     #check das:
2822     $query =
2823       qq|SELECT
2824            d.closedto, d.revtrans,
2825            (SELECT cu.name FROM currencies cu WHERE cu.id=d.currency_id) AS defaultcurrency,
2826            (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2827            (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2828          FROM defaults d|;
2829     $ref = selectfirst_hashref_query($self, $dbh, $query);
2830     map { $self->{$_} = $ref->{$_} } keys %$ref;
2831
2832   } else {
2833
2834     # get date
2835     $query =
2836        qq|SELECT
2837             current_date AS transdate, d.closedto, d.revtrans,
2838             (SELECT cu.name FROM currencies cu WHERE cu.id=d.currency_id) AS defaultcurrency,
2839             (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2840             (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2841           FROM defaults d|;
2842     $ref = selectfirst_hashref_query($self, $dbh, $query);
2843     map { $self->{$_} = $ref->{$_} } keys %$ref;
2844
2845     if ($self->{"$self->{vc}_id"}) {
2846
2847       # only setup currency
2848       ($self->{currency}) = $self->{defaultcurrency} if !$self->{currency};
2849
2850     } else {
2851
2852       $self->lastname_used($dbh, $myconfig, $table, $module);
2853
2854       # get exchangerate for currency
2855       $self->{exchangerate} =
2856         $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2857
2858     }
2859
2860   }
2861
2862   $main::lxdebug->leave_sub();
2863 }
2864
2865 sub lastname_used {
2866   $main::lxdebug->enter_sub();
2867
2868   my ($self, $dbh, $myconfig, $table, $module) = @_;
2869
2870   my ($arap, $where);
2871
2872   $table         = $table eq "customer" ? "customer" : "vendor";
2873   my %column_map = ("a.${table}_id"           => "${table}_id",
2874                     "a.department_id"         => "department_id",
2875                     "d.description"           => "department",
2876                     "ct.name"                 => $table,
2877                     "cu.name"                 => "currency",
2878                     "current_date + ct.terms" => "duedate",
2879     );
2880
2881   if ($self->{type} =~ /delivery_order/) {
2882     $arap  = 'delivery_orders';
2883     delete $column_map{"cu.currency"};
2884
2885   } elsif ($self->{type} =~ /_order/) {
2886     $arap  = 'oe';
2887     $where = "quotation = '0'";
2888
2889   } elsif ($self->{type} =~ /_quotation/) {
2890     $arap  = 'oe';
2891     $where = "quotation = '1'";
2892
2893   } elsif ($table eq 'customer') {
2894     $arap  = 'ar';
2895
2896   } else {
2897     $arap  = 'ap';
2898
2899   }
2900
2901   $where           = "($where) AND" if ($where);
2902   my $query        = qq|SELECT MAX(id) FROM $arap
2903                         WHERE $where ${table}_id > 0|;
2904   my ($trans_id)   = selectrow_query($self, $dbh, $query);
2905   $trans_id       *= 1;
2906
2907   my $column_spec  = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
2908   $query           = qq|SELECT $column_spec
2909                         FROM $arap a
2910                         LEFT JOIN $table     ct ON (a.${table}_id = ct.id)
2911                         LEFT JOIN department d  ON (a.department_id = d.id)
2912                         LEFT JOIN currencies cu ON (cu.id=ct.currency_id)
2913                         WHERE a.id = ?|;
2914   my $ref          = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
2915
2916   map { $self->{$_} = $ref->{$_} } values %column_map;
2917
2918   $main::lxdebug->leave_sub();
2919 }
2920
2921 sub current_date {
2922   $main::lxdebug->enter_sub();
2923
2924   my $self     = shift;
2925   my $myconfig = shift || \%::myconfig;
2926   my ($thisdate, $days) = @_;
2927
2928   my $dbh = $self->get_standard_dbh($myconfig);
2929   my $query;
2930
2931   $days *= 1;
2932   if ($thisdate) {
2933     my $dateformat = $myconfig->{dateformat};
2934     $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
2935     $thisdate = $dbh->quote($thisdate);
2936     $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
2937   } else {
2938     $query = qq|SELECT current_date AS thisdate|;
2939   }
2940
2941   ($thisdate) = selectrow_query($self, $dbh, $query);
2942
2943   $main::lxdebug->leave_sub();
2944
2945   return $thisdate;
2946 }
2947
2948 sub like {
2949   $main::lxdebug->enter_sub();
2950
2951   my ($self, $string) = @_;
2952
2953   if ($string !~ /%/) {
2954     $string = "%$string%";
2955   }
2956
2957   $string =~ s/\'/\'\'/g;
2958
2959   $main::lxdebug->leave_sub();
2960
2961   return $string;
2962 }
2963
2964 sub redo_rows {
2965   $main::lxdebug->enter_sub();
2966
2967   my ($self, $flds, $new, $count, $numrows) = @_;
2968
2969   my @ndx = ();
2970
2971   map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
2972
2973   my $i = 0;
2974
2975   # fill rows
2976   foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
2977     $i++;
2978     my $j = $item->{ndx} - 1;
2979     map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
2980   }
2981
2982   # delete empty rows
2983   for $i ($count + 1 .. $numrows) {
2984     map { delete $self->{"${_}_$i"} } @{$flds};
2985   }
2986
2987   $main::lxdebug->leave_sub();
2988 }
2989
2990 sub update_status {
2991   $main::lxdebug->enter_sub();
2992
2993   my ($self, $myconfig) = @_;
2994
2995   my ($i, $id);
2996
2997   my $dbh = $self->dbconnect_noauto($myconfig);
2998
2999   my $query = qq|DELETE FROM status
3000                  WHERE (formname = ?) AND (trans_id = ?)|;
3001   my $sth = prepare_query($self, $dbh, $query);
3002
3003   if ($self->{formname} =~ /(check|receipt)/) {
3004     for $i (1 .. $self->{rowcount}) {
3005       do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3006     }
3007   } else {
3008     do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3009   }
3010   $sth->finish();
3011
3012   my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3013   my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3014
3015   my %queued = split / /, $self->{queued};
3016   my @values;
3017
3018   if ($self->{formname} =~ /(check|receipt)/) {
3019
3020     # this is a check or receipt, add one entry for each lineitem
3021     my ($accno) = split /--/, $self->{account};
3022     $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3023                 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3024     @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3025     $sth = prepare_query($self, $dbh, $query);
3026
3027     for $i (1 .. $self->{rowcount}) {
3028       if ($self->{"checked_$i"}) {
3029         do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3030       }
3031     }
3032     $sth->finish();
3033
3034   } else {
3035     $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3036                 VALUES (?, ?, ?, ?, ?)|;
3037     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3038              $queued{$self->{formname}}, $self->{formname});
3039   }
3040
3041   $dbh->commit;
3042   $dbh->disconnect;
3043
3044   $main::lxdebug->leave_sub();
3045 }
3046
3047 sub save_status {
3048   $main::lxdebug->enter_sub();
3049
3050   my ($self, $dbh) = @_;
3051
3052   my ($query, $printed, $emailed);
3053
3054   my $formnames  = $self->{printed};
3055   my $emailforms = $self->{emailed};
3056
3057   $query = qq|DELETE FROM status
3058                  WHERE (formname = ?) AND (trans_id = ?)|;
3059   do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3060
3061   # this only applies to the forms
3062   # checks and receipts are posted when printed or queued
3063
3064   if ($self->{queued}) {
3065     my %queued = split / /, $self->{queued};
3066
3067     foreach my $formname (keys %queued) {
3068       $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3069       $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3070
3071       $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3072                   VALUES (?, ?, ?, ?, ?)|;
3073       do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3074
3075       $formnames  =~ s/\Q$self->{formname}\E//;
3076       $emailforms =~ s/\Q$self->{formname}\E//;
3077
3078     }
3079   }
3080
3081   # save printed, emailed info
3082   $formnames  =~ s/^ +//g;
3083   $emailforms =~ s/^ +//g;
3084
3085   my %status = ();
3086   map { $status{$_}{printed} = 1 } split / +/, $formnames;
3087   map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3088
3089   foreach my $formname (keys %status) {
3090     $printed = ($formnames  =~ /\Q$self->{formname}\E/) ? "1" : "0";
3091     $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3092
3093     $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3094                 VALUES (?, ?, ?, ?)|;
3095     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3096   }
3097
3098   $main::lxdebug->leave_sub();
3099 }
3100
3101 #--- 4 locale ---#
3102 # $main::locale->text('SAVED')
3103 # $main::locale->text('DELETED')
3104 # $main::locale->text('ADDED')
3105 # $main::locale->text('PAYMENT POSTED')
3106 # $main::locale->text('POSTED')
3107 # $main::locale->text('POSTED AS NEW')
3108 # $main::locale->text('ELSE')
3109 # $main::locale->text('SAVED FOR DUNNING')
3110 # $main::locale->text('DUNNING STARTED')
3111 # $main::locale->text('PRINTED')
3112 # $main::locale->text('MAILED')
3113 # $main::locale->text('SCREENED')
3114 # $main::locale->text('CANCELED')
3115 # $main::locale->text('invoice')
3116 # $main::locale->text('proforma')
3117 # $main::locale->text('sales_order')
3118 # $main::locale->text('pick_list')
3119 # $main::locale->text('purchase_order')
3120 # $main::locale->text('bin_list')
3121 # $main::locale->text('sales_quotation')
3122 # $main::locale->text('request_quotation')
3123
3124 sub save_history {
3125   $main::lxdebug->enter_sub();
3126
3127   my $self = shift;
3128   my $dbh  = shift || $self->get_standard_dbh;
3129
3130   if(!exists $self->{employee_id}) {
3131     &get_employee($self, $dbh);
3132   }
3133
3134   my $query =
3135    qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3136    qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3137   my @values = (conv_i($self->{id}), $self->{login},
3138                 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3139   do_query($self, $dbh, $query, @values);
3140
3141   $dbh->commit;
3142
3143   $main::lxdebug->leave_sub();
3144 }
3145
3146 sub get_history {
3147   $main::lxdebug->enter_sub();
3148
3149   my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3150   my ($orderBy, $desc) = split(/\-\-/, $order);
3151   $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3152   my @tempArray;
3153   my $i = 0;
3154   if ($trans_id ne "") {
3155     my $query =
3156       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 | .
3157       qq|FROM history_erp h | .
3158       qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3159       qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3160       $order;
3161
3162     my $sth = $dbh->prepare($query) || $self->dberror($query);
3163
3164     $sth->execute() || $self->dberror("$query");
3165
3166     while(my $hash_ref = $sth->fetchrow_hashref()) {
3167       $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3168       $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3169       $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3170       $tempArray[$i++] = $hash_ref;
3171     }
3172     $main::lxdebug->leave_sub() and return \@tempArray
3173       if ($i > 0 && $tempArray[0] ne "");
3174   }
3175   $main::lxdebug->leave_sub();
3176   return 0;
3177 }
3178
3179 sub update_defaults {
3180   $main::lxdebug->enter_sub();
3181
3182   my ($self, $myconfig, $fld, $provided_dbh) = @_;
3183
3184   my $dbh;
3185   if ($provided_dbh) {
3186     $dbh = $provided_dbh;
3187   } else {
3188     $dbh = $self->dbconnect_noauto($myconfig);
3189   }
3190   my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3191   my $sth   = $dbh->prepare($query);
3192
3193   $sth->execute || $self->dberror($query);
3194   my ($var) = $sth->fetchrow_array;
3195   $sth->finish;
3196
3197   $var   = 0 if !defined($var) || ($var eq '');
3198   $var   = SL::PrefixedNumber->new(number => $var)->get_next;
3199   $query = qq|UPDATE defaults SET $fld = ?|;
3200   do_query($self, $dbh, $query, $var);
3201
3202   if (!$provided_dbh) {
3203     $dbh->commit;
3204     $dbh->disconnect;
3205   }
3206
3207   $main::lxdebug->leave_sub();
3208
3209   return $var;
3210 }
3211
3212 sub update_business {
3213   $main::lxdebug->enter_sub();
3214
3215   my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3216
3217   my $dbh;
3218   if ($provided_dbh) {
3219     $dbh = $provided_dbh;
3220   } else {
3221     $dbh = $self->dbconnect_noauto($myconfig);
3222   }
3223   my $query =
3224     qq|SELECT customernumberinit FROM business
3225        WHERE id = ? FOR UPDATE|;
3226   my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3227
3228   return undef unless $var;
3229
3230   if ($var =~ m/\d+$/) {
3231     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3232     my $len_diff = length($var) - $-[0] - length($new_var);
3233     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3234
3235   } else {
3236     $var = $var . '1';
3237   }
3238
3239   $query = qq|UPDATE business
3240               SET customernumberinit = ?
3241               WHERE id = ?|;
3242   do_query($self, $dbh, $query, $var, $business_id);
3243
3244   if (!$provided_dbh) {
3245     $dbh->commit;
3246     $dbh->disconnect;
3247   }
3248
3249   $main::lxdebug->leave_sub();
3250
3251   return $var;
3252 }
3253
3254 sub get_partsgroup {
3255   $main::lxdebug->enter_sub();
3256
3257   my ($self, $myconfig, $p) = @_;
3258   my $target = $p->{target} || 'all_partsgroup';
3259
3260   my $dbh = $self->get_standard_dbh($myconfig);
3261
3262   my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3263                  FROM partsgroup pg
3264                  JOIN parts p ON (p.partsgroup_id = pg.id) |;
3265   my @values;
3266
3267   if ($p->{searchitems} eq 'part') {
3268     $query .= qq|WHERE p.inventory_accno_id > 0|;
3269   }
3270   if ($p->{searchitems} eq 'service') {
3271     $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3272   }
3273   if ($p->{searchitems} eq 'assembly') {
3274     $query .= qq|WHERE p.assembly = '1'|;
3275   }
3276   if ($p->{searchitems} eq 'labor') {
3277     $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3278   }
3279
3280   $query .= qq|ORDER BY partsgroup|;
3281
3282   if ($p->{all}) {
3283     $query = qq|SELECT id, partsgroup FROM partsgroup
3284                 ORDER BY partsgroup|;
3285   }
3286
3287   if ($p->{language_code}) {
3288     $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3289                   t.description AS translation
3290                 FROM partsgroup pg
3291                 JOIN parts p ON (p.partsgroup_id = pg.id)
3292                 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3293                 ORDER BY translation|;
3294     @values = ($p->{language_code});
3295   }
3296
3297   $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3298
3299   $main::lxdebug->leave_sub();
3300 }
3301
3302 sub get_pricegroup {
3303   $main::lxdebug->enter_sub();
3304
3305   my ($self, $myconfig, $p) = @_;
3306
3307   my $dbh = $self->get_standard_dbh($myconfig);
3308
3309   my $query = qq|SELECT p.id, p.pricegroup
3310                  FROM pricegroup p|;
3311
3312   $query .= qq| ORDER BY pricegroup|;
3313
3314   if ($p->{all}) {
3315     $query = qq|SELECT id, pricegroup FROM pricegroup
3316                 ORDER BY pricegroup|;
3317   }
3318
3319   $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3320
3321   $main::lxdebug->leave_sub();
3322 }
3323
3324 sub all_years {
3325 # usage $form->all_years($myconfig, [$dbh])
3326 # return list of all years where bookings found
3327 # (@all_years)
3328
3329   $main::lxdebug->enter_sub();
3330
3331   my ($self, $myconfig, $dbh) = @_;
3332
3333   $dbh ||= $self->get_standard_dbh($myconfig);
3334
3335   # get years
3336   my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3337                    (SELECT MAX(transdate) FROM acc_trans)|;
3338   my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3339
3340   if ($myconfig->{dateformat} =~ /^yy/) {
3341     ($startdate) = split /\W/, $startdate;
3342     ($enddate) = split /\W/, $enddate;
3343   } else {
3344     (@_) = split /\W/, $startdate;
3345     $startdate = $_[2];
3346     (@_) = split /\W/, $enddate;
3347     $enddate = $_[2];
3348   }
3349
3350   my @all_years;
3351   $startdate = substr($startdate,0,4);
3352   $enddate = substr($enddate,0,4);
3353
3354   while ($enddate >= $startdate) {
3355     push @all_years, $enddate--;
3356   }
3357
3358   return @all_years;
3359
3360   $main::lxdebug->leave_sub();
3361 }
3362
3363 sub backup_vars {
3364   $main::lxdebug->enter_sub();
3365   my $self = shift;
3366   my @vars = @_;
3367
3368   map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3369
3370   $main::lxdebug->leave_sub();
3371 }
3372
3373 sub restore_vars {
3374   $main::lxdebug->enter_sub();
3375
3376   my $self = shift;
3377   my @vars = @_;
3378
3379   map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3380
3381   $main::lxdebug->leave_sub();
3382 }
3383
3384 sub prepare_for_printing {
3385   my ($self) = @_;
3386
3387   $self->{templates} ||= $::myconfig{templates};
3388   $self->{formname}  ||= $self->{type};
3389   $self->{media}     ||= 'email';
3390
3391   die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3392
3393   # set shipto from billto unless set
3394   my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3395   if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3396     $self->{shiptoname}   = $::myconfig{company};
3397     $self->{shiptostreet} = $::myconfig{address};
3398   }
3399
3400   my $language = $self->{language} ? '_' . $self->{language} : '';
3401
3402   my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3403   if ($self->{language_id}) {
3404     ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3405   } else {
3406     $output_dateformat   = $::myconfig{dateformat};
3407     $output_numberformat = $::myconfig{numberformat};
3408     $output_longdates    = 1;
3409   }
3410
3411   # Retrieve accounts for tax calculation.
3412   IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3413
3414   if ($self->{type} =~ /_delivery_order$/) {
3415     DO->order_details(\%::myconfig, $self);
3416   } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3417     OE->order_details(\%::myconfig, $self);
3418   } else {
3419     IS->invoice_details(\%::myconfig, $self, $::locale);
3420   }
3421
3422   # Chose extension & set source file name
3423   my $extension = 'html';
3424   if ($self->{format} eq 'postscript') {
3425     $self->{postscript}   = 1;
3426     $extension            = 'tex';
3427   } elsif ($self->{"format"} =~ /pdf/) {
3428     $self->{pdf}          = 1;
3429     $extension            = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3430   } elsif ($self->{"format"} =~ /opendocument/) {
3431     $self->{opendocument} = 1;
3432     $extension            = 'odt';
3433   } elsif ($self->{"format"} =~ /excel/) {
3434     $self->{excel}        = 1;
3435     $extension            = 'xls';
3436   }
3437
3438   my $printer_code    = $self->{printer_code} ? '_' . $self->{printer_code} : '';
3439   my $email_extension = -f "$::myconfig{templates}/$self->{formname}_email${language}.${extension}" ? '_email' : '';
3440   $self->{IN}         = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3441
3442   # Format dates.
3443   $self->format_dates($output_dateformat, $output_longdates,
3444                       qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3445                          transdate_oe deliverydate_oe employee_startdate employee_enddate),
3446                       grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3447
3448   $self->reformat_numbers($output_numberformat, 2,
3449                           qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3450                           grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3451
3452   $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3453
3454   my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3455
3456   if (scalar @{ $cvar_date_fields }) {
3457     $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3458   }
3459
3460   while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3461     $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3462   }
3463
3464   return $self;
3465 }
3466
3467 sub format_dates {
3468   my ($self, $dateformat, $longformat, @indices) = @_;
3469
3470   $dateformat ||= $::myconfig{dateformat};
3471
3472   foreach my $idx (@indices) {
3473     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3474       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3475         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3476       }
3477     }
3478
3479     next unless defined $self->{$idx};
3480
3481     if (!ref($self->{$idx})) {
3482       $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3483
3484     } elsif (ref($self->{$idx}) eq "ARRAY") {
3485       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3486         $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3487       }
3488     }
3489   }
3490 }
3491
3492 sub reformat_numbers {
3493   my ($self, $numberformat, $places, @indices) = @_;
3494
3495   return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3496
3497   foreach my $idx (@indices) {
3498     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3499       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3500         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3501       }
3502     }
3503
3504     next unless defined $self->{$idx};
3505
3506     if (!ref($self->{$idx})) {
3507       $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3508
3509     } elsif (ref($self->{$idx}) eq "ARRAY") {
3510       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3511         $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3512       }
3513     }
3514   }
3515
3516   my $saved_numberformat    = $::myconfig{numberformat};
3517   $::myconfig{numberformat} = $numberformat;
3518
3519   foreach my $idx (@indices) {
3520     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3521       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3522         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3523       }
3524     }
3525
3526     next unless defined $self->{$idx};
3527
3528     if (!ref($self->{$idx})) {
3529       $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3530
3531     } elsif (ref($self->{$idx}) eq "ARRAY") {
3532       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3533         $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3534       }
3535     }
3536   }
3537
3538   $::myconfig{numberformat} = $saved_numberformat;
3539 }
3540
3541 sub layout {
3542   my ($self) = @_;
3543   $::lxdebug->enter_sub;
3544
3545   my %style_to_script_map = (
3546     v3  => 'v3',
3547     neu => 'new',
3548   );
3549
3550   my $menu_script = $style_to_script_map{$::myconfig{menustyle}} || '';
3551
3552   package main;
3553   require "bin/mozilla/menu$menu_script.pl";
3554   package Form;
3555   require SL::Controller::FrameHeader;
3556
3557
3558   my $layout = SL::Controller::FrameHeader->new->action_header . ::render();
3559
3560   $::lxdebug->leave_sub;
3561   return $layout;
3562 }
3563
3564 1;
3565
3566 __END__
3567
3568 =head1 NAME
3569
3570 SL::Form.pm - main data object.
3571
3572 =head1 SYNOPSIS
3573
3574 This is the main data object of kivitendo.
3575 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3576 Points of interest for a beginner are:
3577
3578  - $form->error            - renders a generic error in html. accepts an error message
3579  - $form->get_standard_dbh - returns a database connection for the
3580
3581 =head1 SPECIAL FUNCTIONS
3582
3583 =head2 C<update_business> PARAMS
3584
3585 PARAMS (not named):
3586  \%config,     - config hashref
3587  $business_id, - business id
3588  $dbh          - optional database handle
3589
3590 handles business (thats customer/vendor types) sequences.
3591
3592 special behaviour for empty strings in customerinitnumber field:
3593 will in this case not increase the value, and return undef.
3594
3595 =head2 C<redirect_header> $url
3596
3597 Generates a HTTP redirection header for the new C<$url>. Constructs an
3598 absolute URL including scheme, host name and port. If C<$url> is a
3599 relative URL then it is considered relative to kivitendo base URL.
3600
3601 This function C<die>s if headers have already been created with
3602 C<$::form-E<gt>header>.
3603
3604 Examples:
3605
3606   print $::form->redirect_header('oe.pl?action=edit&id=1234');
3607   print $::form->redirect_header('http://www.lx-office.org/');
3608
3609 =head2 C<header>
3610
3611 Generates a general purpose http/html header and includes most of the scripts
3612 and stylesheets needed. Stylesheets can be added with L<use_stylesheet>.
3613
3614 Only one header will be generated. If the method was already called in this
3615 request it will not output anything and return undef. Also if no
3616 HTTP_USER_AGENT is found, no header is generated.
3617
3618 Although header does not accept parameters itself, it will honor special
3619 hashkeys of its Form instance:
3620
3621 =over 4
3622
3623 =item refresh_time
3624
3625 =item refresh_url
3626
3627 If one of these is set, a http-equiv refresh is generated. Missing parameters
3628 default to 3 seconds and the refering url.
3629
3630 =item stylesheet
3631
3632 Either a scalar or an array ref. Will be inlined into the header. Add
3633 stylesheets with the L<use_stylesheet> function.
3634
3635 =item landscape
3636
3637 If true, a css snippet will be generated that sets the page in landscape mode.
3638
3639 =item favicon
3640
3641 Used to override the default favicon.
3642
3643 =item title
3644
3645 A html page title will be generated from this
3646
3647 =back
3648
3649 =cut