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