SL/Form.pm

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