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