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