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