SL/Form.pm

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