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