SL/Form.pm

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