SL/Form.pm

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