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