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