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