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