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 $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
 451   my @header;
 452
 453   $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
 454
 455   if ($params{no_layout}) {
 456     $::request->{layout} = SL::Layout::Dispatcher->new(style => 'none');
 457   }
 458
 459   my $layout = $::request->{layout};
 460
 461   # standard css for all
 462   # this should gradually move to the layouts that need it
 463   $layout->use_stylesheet("$_.css") for qw(
 464     main menu list_accounts jquery.autocomplete
 465     jquery.multiselect2side frame_header/header
 466     ui-lightness/jquery-ui
 467     jquery-ui.custom jqModal
 468   );
 469
 470   $layout->use_javascript("$_.js") for (qw(
 471     jquery jquery-ui jquery.cookie jqModal jquery.checkall jquery.download
 472     common part_selection switchmenuframe
 473   ), "jquery/ui/i18n/jquery.ui.datepicker-$::myconfig{countrycode}");
 474
 475   $self->{favicon} ||= "favicon.ico";
 476   $self->{titlebar} = join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title} || !$self->{titlebar};
 477
 478   # build includes
 479   if ($self->{refresh_url} || $self->{refresh_time}) {
 480     my $refresh_time = $self->{refresh_time} || 3;
 481     my $refresh_url  = $self->{refresh_url}  || $ENV{REFERER};
 482     push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
 483   }
 484
 485   my $auto_reload_resources_param = $layout->auto_reload_resources_param;
 486
 487   push @header, map { qq|<link rel="stylesheet" href="${_}${auto_reload_resources_param}" type="text/css" title="Stylesheet">| } $layout->stylesheets;
 488   push @header, "<style type='text/css'>\@page { size:landscape; }</style> "                     if $self->{landscape};
 489   push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>"         if -f $self->{favicon};
 490   push @header, map { qq|<script type="text/javascript" src="${_}${auto_reload_resources_param}"></script>| }                    $layout->javascripts;
 491   push @header, $self->{javascript} if $self->{javascript};
 492   push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
 493
 494   my  %doctypes = (
 495     strict       => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">|,
 496     transitional => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">|,
 497     frameset     => qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN" "http://www.w3.org/TR/html4/frameset.dtd">|,
 498     html5        => qq|<!DOCTYPE html>|,
 499   );
 500
 501   # output
 502   print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
 503   print $doctypes{$params{doctype} || 'transitional'}, $/;
 504   print <<EOT;
 505 <html>
 506  <head>
 507   <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
 508   <title>$self->{titlebar}</title>
 509 EOT
 510   print "  $_\n" for @header;
 511   print <<EOT;
 512   <meta name="robots" content="noindex,nofollow">
 513  </head>
 514  <body>
 515
 516 EOT
 517   print $::request->{layout}->pre_content;
 518   print $::request->{layout}->start_content;
 519
 520   $layout->header_done;
 521
 522   $::lxdebug->leave_sub;
 523 }
 524
 525 sub footer {
 526   return unless $::request->{layout}->need_footer;
 527
 528   print $::request->{layout}->end_content;
 529   print $::request->{layout}->post_content;
 530
 531   if (my @inline_scripts = $::request->{layout}->javascripts_inline) {
 532     print "<script type='text/javascript'>@inline_scripts</script>\n";
 533   }
 534
 535   print <<EOL
 536  </body>
 537 </html>
 538 EOL
 539 }
 540
 541 sub ajax_response_header {
 542   $main::lxdebug->enter_sub();
 543
 544   my ($self) = @_;
 545
 546   my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
 547   my $output     = $::request->{cgi}->header('-charset' => $db_charset);
 548
 549   $main::lxdebug->leave_sub();
 550
 551   return $output;
 552 }
 553
 554 sub redirect_header {
 555   my $self     = shift;
 556   my $new_url  = shift;
 557
 558   my $base_uri = $self->_get_request_uri;
 559   my $new_uri  = URI->new_abs($new_url, $base_uri);
 560
 561   die "Headers already sent" if $self->{header};
 562   $self->{header} = 1;
 563
 564   return $::request->{cgi}->redirect($new_uri);
 565 }
 566
 567 sub set_standard_title {
 568   $::lxdebug->enter_sub;
 569   my $self = shift;
 570
 571   $self->{titlebar}  = "kivitendo " . $::locale->text('Version') . " $self->{version}";
 572   $self->{titlebar} .= "- $::myconfig{name}"   if $::myconfig{name};
 573   $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
 574
 575   $::lxdebug->leave_sub;
 576 }
 577
 578 sub _prepare_html_template {
 579   $main::lxdebug->enter_sub();
 580
 581   my ($self, $file, $additional_params) = @_;
 582   my $language;
 583
 584   if (!%::myconfig || !$::myconfig{"countrycode"}) {
 585     $language = $::lx_office_conf{system}->{language};
 586   } else {
 587     $language = $main::myconfig{"countrycode"};
 588   }
 589   $language = "de" unless ($language);
 590
 591   if (-f "templates/webpages/${file}.html") {
 592     $file = "templates/webpages/${file}.html";
 593
 594   } else {
 595     my $info = "Web page template '${file}' not found.\n";
 596     print qq|<pre>$info</pre>|;
 597     ::end_of_request();
 598   }
 599
 600   if ($self->{"DEBUG"}) {
 601     $additional_params->{"DEBUG"} = $self->{"DEBUG"};
 602   }
 603
 604   if ($additional_params->{"DEBUG"}) {
 605     $additional_params->{"DEBUG"} =
 606       "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
 607   }
 608
 609   if (%main::myconfig) {
 610     $::myconfig{jsc_dateformat} = apply {
 611       s/d+/\%d/gi;
 612       s/m+/\%m/gi;
 613       s/y+/\%Y/gi;
 614     } $::myconfig{"dateformat"};
 615     $additional_params->{"myconfig"} ||= \%::myconfig;
 616     map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
 617   }
 618
 619   $additional_params->{"conf_dbcharset"}              = $::lx_office_conf{system}->{dbcharset};
 620   $additional_params->{"conf_webdav"}                 = $::lx_office_conf{features}->{webdav};
 621   $additional_params->{"conf_latex_templates"}        = $::lx_office_conf{print_templates}->{latex};
 622   $additional_params->{"conf_opendocument_templates"} = $::lx_office_conf{print_templates}->{opendocument};
 623   $additional_params->{"conf_vertreter"}              = $::lx_office_conf{features}->{vertreter};
 624   $additional_params->{"conf_parts_image_css"}        = $::lx_office_conf{features}->{parts_image_css};
 625   $additional_params->{"conf_parts_listing_images"}   = $::lx_office_conf{features}->{parts_listing_images};
 626   $additional_params->{"conf_parts_show_image"}       = $::lx_office_conf{features}->{parts_show_image};
 627   $additional_params->{"INSTANCE_CONF"}               = $::instance_conf;
 628
 629   if (my $debug_options = $::lx_office_conf{debug}{options}) {
 630     map { $additional_params->{'DEBUG_' . uc($_)} = $debug_options->{$_} } keys %$debug_options;
 631   }
 632
 633   if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
 634     while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
 635       $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
 636     }
 637   }
 638
 639   $main::lxdebug->leave_sub();
 640
 641   return $file;
 642 }
 643
 644 sub parse_html_template {
 645   $main::lxdebug->enter_sub();
 646
 647   my ($self, $file, $additional_params) = @_;
 648
 649   $additional_params ||= { };
 650
 651   my $real_file = $self->_prepare_html_template($file, $additional_params);
 652   my $template  = $self->template || $self->init_template;
 653
 654   map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
 655
 656   my $output;
 657   $template->process($real_file, $additional_params, \$output) || die $template->error;
 658
 659   $main::lxdebug->leave_sub();
 660
 661   return $output;
 662 }
 663
 664 sub init_template {
 665   my $self = shift;
 666
 667   return $self->template if $self->template;
 668
 669   # Force scripts/locales.pl to pick up the exception handling template.
 670   # parse_html_template('generic/exception')
 671   return $self->template(Template->new({
 672      'INTERPOLATE'  => 0,
 673      'EVAL_PERL'    => 0,
 674      'ABSOLUTE'     => 1,
 675      'CACHE_SIZE'   => 0,
 676      'PLUGIN_BASE'  => 'SL::Template::Plugin',
 677      'INCLUDE_PATH' => '.:templates/webpages',
 678      'COMPILE_EXT'  => '.tcc',
 679      'COMPILE_DIR'  => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
 680      'ERROR'        => 'templates/webpages/generic/exception.html',
 681   })) || die;
 682 }
 683
 684 sub template {
 685   my $self = shift;
 686   $self->{template_object} = shift if @_;
 687   return $self->{template_object};
 688 }
 689
 690 sub show_generic_error {
 691   $main::lxdebug->enter_sub();
 692
 693   my ($self, $error, %params) = @_;
 694
 695   if ($self->{__ERROR_HANDLER}) {
 696     $self->{__ERROR_HANDLER}->($error);
 697     $main::lxdebug->leave_sub();
 698     return;
 699   }
 700
 701   if ($::request->is_ajax) {
 702     $::lxdebug->message(0, "trying to render AJAX response...");
 703     SL::ClientJS->new
 704       ->error($error)
 705       ->render(SL::Controller::Base->new);
 706     ::end_of_request();
 707   }
 708
 709   my $add_params = {
 710     'title_error' => $params{title},
 711     'label_error' => $error,
 712   };
 713
 714   if ($params{action}) {
 715     my @vars;
 716
 717     map { delete($self->{$_}); } qw(action);
 718     map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
 719
 720     $add_params->{SHOW_BUTTON}  = 1;
 721     $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
 722     $add_params->{VARIABLES}    = \@vars;
 723
 724   } elsif ($params{back_button}) {
 725     $add_params->{SHOW_BACK_BUTTON} = 1;
 726   }
 727
 728   $self->{title} = $params{title} if $params{title};
 729
 730   $self->header();
 731   print $self->parse_html_template("generic/error", $add_params);
 732
 733   print STDERR "Error: $error\n";
 734
 735   $main::lxdebug->leave_sub();
 736
 737   ::end_of_request();
 738 }
 739
 740 sub show_generic_information {
 741   $main::lxdebug->enter_sub();
 742
 743   my ($self, $text, $title) = @_;
 744
 745   my $add_params = {
 746     'title_information' => $title,
 747     'label_information' => $text,
 748   };
 749
 750   $self->{title} = $title if ($title);
 751
 752   $self->header();
 753   print $self->parse_html_template("generic/information", $add_params);
 754
 755   $main::lxdebug->leave_sub();
 756
 757   ::end_of_request();
 758 }
 759
 760 sub _store_redirect_info_in_session {
 761   my ($self) = @_;
 762
 763   return unless $self->{callback} =~ m:^ ( [^\?/]+ \.pl ) \? (.+) :x;
 764
 765   my ($controller, $params) = ($1, $2);
 766   my $form                  = { map { map { $self->unescape($_) } split /=/, $_, 2 } split m/\&/, $params };
 767   $self->{callback}         = "${controller}?RESTORE_FORM_FROM_SESSION_ID=" . $::auth->save_form_in_session(form => $form);
 768 }
 769
 770 sub redirect {
 771   $main::lxdebug->enter_sub();
 772
 773   my ($self, $msg) = @_;
 774
 775   if (!$self->{callback}) {
 776     $self->info($msg);
 777
 778   } else {
 779     $self->_store_redirect_info_in_session;
 780     print $::form->redirect_header($self->{callback});
 781   }
 782
 783   ::end_of_request();
 784
 785   $main::lxdebug->leave_sub();
 786 }
 787
 788 # sort of columns removed - empty sub
 789 sub sort_columns {
 790   $main::lxdebug->enter_sub();
 791
 792   my ($self, @columns) = @_;
 793
 794   $main::lxdebug->leave_sub();
 795
 796   return @columns;
 797 }
 798 #
 799 sub format_amount {
 800   $main::lxdebug->enter_sub(2);
 801
 802   my ($self, $myconfig, $amount, $places, $dash) = @_;
 803   $amount ||= 0;
 804   $dash   ||= '';
 805   my $neg = $amount < 0;
 806   my $force_places = defined $places && $places >= 0;
 807
 808   $amount = $self->round_amount($amount, abs $places) if $force_places;
 809   $amount = sprintf "%.*f", ($force_places ? $places : 10), abs $amount; # 6 is default for %fa
 810
 811   # before the sprintf amount was a number, afterwards it's a string. because of the dynamic nature of perl
 812   # this is easy to confuse, so keep in mind: before this comment no s///, m//, concat or other strong ops on
 813   # $amount. after this comment no +,-,*,/,abs. it will only introduce subtle bugs.
 814
 815   $amount =~ s/0*$// unless defined $places && $places == 0;             # cull trailing 0s
 816
 817   my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
 818   my @p = split(/\./, $amount);                                          # split amount at decimal point
 819
 820   $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1];                             # add 1,000 delimiters
 821   $amount = $p[0];
 822   if ($places || $p[1]) {
 823     $amount .= $d[0]
 824             .  ( $p[1] || '' )
 825             .  (0 x (abs($places || 0) - length ($p[1]||'')));           # pad the fraction
 826   }
 827
 828   $amount = do {
 829     ($dash =~ /-/)    ? ($neg ? "($amount)"                            : "$amount" )                              :
 830     ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
 831                         ($neg ? "-$amount"                             : "$amount" )                              ;
 832   };
 833
 834   $main::lxdebug->leave_sub(2);
 835   return $amount;
 836 }
 837
 838 sub format_amount_units {
 839   $main::lxdebug->enter_sub();
 840
 841   my $self             = shift;
 842   my %params           = @_;
 843
 844   my $myconfig         = \%main::myconfig;
 845   my $amount           = $params{amount} * 1;
 846   my $places           = $params{places};
 847   my $part_unit_name   = $params{part_unit};
 848   my $amount_unit_name = $params{amount_unit};
 849   my $conv_units       = $params{conv_units};
 850   my $max_places       = $params{max_places};
 851
 852   if (!$part_unit_name) {
 853     $main::lxdebug->leave_sub();
 854     return '';
 855   }
 856
 857   my $all_units        = AM->retrieve_all_units;
 858
 859   if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
 860     $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
 861   }
 862
 863   if (!scalar @{ $conv_units }) {
 864     my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
 865     $main::lxdebug->leave_sub();
 866     return $result;
 867   }
 868
 869   my $part_unit  = $all_units->{$part_unit_name};
 870   my $conv_unit  = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
 871
 872   $amount       *= $conv_unit->{factor};
 873
 874   my @values;
 875   my $num;
 876
 877   foreach my $unit (@$conv_units) {
 878     my $last = $unit->{name} eq $part_unit->{name};
 879     if (!$last) {
 880       $num     = int($amount / $unit->{factor});
 881       $amount -= $num * $unit->{factor};
 882     }
 883
 884     if ($last ? $amount : $num) {
 885       push @values, { "unit"   => $unit->{name},
 886                       "amount" => $last ? $amount / $unit->{factor} : $num,
 887                       "places" => $last ? $places : 0 };
 888     }
 889
 890     last if $last;
 891   }
 892
 893   if (!@values) {
 894     push @values, { "unit"   => $part_unit_name,
 895                     "amount" => 0,
 896                     "places" => 0 };
 897   }
 898
 899   my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
 900
 901   $main::lxdebug->leave_sub();
 902
 903   return $result;
 904 }
 905
 906 sub format_string {
 907   $main::lxdebug->enter_sub(2);
 908
 909   my $self  = shift;
 910   my $input = shift;
 911
 912   $input =~ s/(^|[^\#]) \#  (\d+)  /$1$_[$2 - 1]/gx;
 913   $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
 914   $input =~ s/\#\#/\#/g;
 915
 916   $main::lxdebug->leave_sub(2);
 917
 918   return $input;
 919 }
 920
 921 #
 922
 923 sub parse_amount {
 924   $main::lxdebug->enter_sub(2);
 925
 926   my ($self, $myconfig, $amount) = @_;
 927
 928   if (!defined($amount) || ($amount eq '')) {
 929     $main::lxdebug->leave_sub(2);
 930     return 0;
 931   }
 932
 933   if (   ($myconfig->{numberformat} eq '1.000,00')
 934       || ($myconfig->{numberformat} eq '1000,00')) {
 935     $amount =~ s/\.//g;
 936     $amount =~ s/,/\./g;
 937   }
 938
 939   if ($myconfig->{numberformat} eq "1'000.00") {
 940     $amount =~ s/\'//g;
 941   }
 942
 943   $amount =~ s/,//g;
 944
 945   $main::lxdebug->leave_sub(2);
 946
 947   # Make sure no code wich is not a math expression ends up in eval().
 948   return 0 unless $amount =~ /^ [\s \d \( \) \- \+ \* \/ \. ]* $/x;
 949   return scalar(eval($amount)) * 1 ;
 950 }
 951
 952 sub round_amount {
 953   $main::lxdebug->enter_sub(2);
 954
 955   my ($self, $amount, $places) = @_;
 956   my $round_amount;
 957
 958   # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
 959
 960   # Round amounts to eight places before rounding to the requested
 961   # number of places. This gets rid of errors due to internal floating
 962   # point representation.
 963   $amount       = $self->round_amount($amount, 8) if $places < 8;
 964   $amount       = $amount * (10**($places));
 965   $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
 966
 967   $main::lxdebug->leave_sub(2);
 968
 969   return $round_amount;
 970
 971 }
 972
 973 sub parse_template {
 974   $main::lxdebug->enter_sub();
 975
 976   my ($self, $myconfig) = @_;
 977   my ($out, $out_mode);
 978
 979   local (*IN, *OUT);
 980
 981   my $userspath = $::lx_office_conf{paths}->{userspath};
 982
 983   $self->{"cwd"} = getcwd();
 984   $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
 985
 986   my $ext_for_format;
 987
 988   my $template_type;
 989   if ($self->{"format"} =~ /(opendocument|oasis)/i) {
 990     $template_type  = 'OpenDocument';
 991     $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
 992
 993   } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
 994     $template_type    = 'LaTeX';
 995     $ext_for_format   = 'pdf';
 996
 997   } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
 998     $template_type  = 'HTML';
 999     $ext_for_format = 'html';
1000
1001   } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1002     $template_type  = 'XML';
1003     $ext_for_format = 'xml';
1004
1005   } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1006     $template_type = 'XML';
1007
1008   } elsif ( $self->{"format"} =~ /excel/i ) {
1009     $template_type  = 'Excel';
1010     $ext_for_format = 'xls';
1011
1012   } elsif ( defined $self->{'format'}) {
1013     $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1014
1015   } elsif ( $self->{'format'} eq '' ) {
1016     $self->error("No Outputformat given: $self->{'format'}");
1017
1018   } else { #Catch the rest
1019     $self->error("Outputformat not defined: $self->{'format'}");
1020   }
1021
1022   my $template = SL::Template::create(type      => $template_type,
1023                                       file_name => $self->{IN},
1024                                       form      => $self,
1025                                       myconfig  => $myconfig,
1026                                       userspath => $userspath);
1027
1028   # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1029   $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1030
1031   if (!$self->{employee_id}) {
1032     map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1033   }
1034
1035   map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1036   map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
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
1080   close OUT if $self->{OUT};
1081
1082   if ($self->{media} eq 'file') {
1083     copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1084     $self->cleanup;
1085     chdir("$self->{cwd}");
1086
1087     $::lxdebug->leave_sub();
1088
1089     return;
1090   }
1091
1092   if ($template->uses_temp_file() || $self->{media} eq 'email') {
1093
1094     if ($self->{media} eq 'email') {
1095
1096       my $mail = new Mailer;
1097
1098       map { $mail->{$_} = $self->{$_} }
1099         qw(cc bcc subject message version format);
1100       $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
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   my @currencies =();
1634
1635   my $query = qq|SELECT name FROM currencies|;
1636   my @currencies = map { $_->{name} } selectall_hashref_query($self, $dbh, $query);
1637
1638   $main::lxdebug->leave_sub();
1639
1640   return @currencies;
1641 }
1642
1643 sub get_default_currency {
1644   $main::lxdebug->enter_sub();
1645
1646   my ($self, $myconfig) = @_;
1647   my $dbh      = $self->get_standard_dbh($myconfig);
1648   my $query = qq|SELECT name AS curr FROM currencies WHERE id = (SELECT currency_id FROM defaults)|;
1649
1650   my ($defaultcurrency) = selectrow_query($self, $dbh, $query);
1651
1652   $main::lxdebug->leave_sub();
1653
1654   return $defaultcurrency;
1655 }
1656
1657 sub set_payment_options {
1658   $main::lxdebug->enter_sub();
1659
1660   my ($self, $myconfig, $transdate) = @_;
1661
1662   return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1663
1664   my $dbh = $self->get_standard_dbh($myconfig);
1665
1666   my $query =
1667     qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long , p.description | .
1668     qq|FROM payment_terms p | .
1669     qq|WHERE p.id = ?|;
1670
1671   ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1672    $self->{payment_terms}, $self->{payment_description}) =
1673      selectrow_query($self, $dbh, $query, $self->{payment_id});
1674
1675   if ($transdate eq "") {
1676     if ($self->{invdate}) {
1677       $transdate = $self->{invdate};
1678     } else {
1679       $transdate = $self->{transdate};
1680     }
1681   }
1682
1683   $query =
1684     qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1685     qq|FROM payment_terms|;
1686   ($self->{netto_date}, $self->{skonto_date}) =
1687     selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1688
1689   my ($invtotal, $total);
1690   my (%amounts, %formatted_amounts);
1691
1692   if ($self->{type} =~ /_order$/) {
1693     $amounts{invtotal} = $self->{ordtotal};
1694     $amounts{total}    = $self->{ordtotal};
1695
1696   } elsif ($self->{type} =~ /_quotation$/) {
1697     $amounts{invtotal} = $self->{quototal};
1698     $amounts{total}    = $self->{quototal};
1699
1700   } else {
1701     $amounts{invtotal} = $self->{invtotal};
1702     $amounts{total}    = $self->{total};
1703   }
1704   map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1705
1706   $amounts{skonto_in_percent}  = 100.0 * $self->{percent_skonto};
1707   $amounts{skonto_amount}      = $amounts{invtotal} * $self->{percent_skonto};
1708   $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1709   $amounts{total_wo_skonto}    = $amounts{total}    * (1 - $self->{percent_skonto});
1710
1711   foreach (keys %amounts) {
1712     $amounts{$_}           = $self->round_amount($amounts{$_}, 2);
1713     $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1714   }
1715
1716   if ($self->{"language_id"}) {
1717     $query =
1718       qq|SELECT t.translation, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1719       qq|FROM generic_translations t | .
1720       qq|LEFT JOIN language l ON t.language_id = l.id | .
1721       qq|WHERE (t.language_id = ?)
1722            AND (t.translation_id = ?)
1723            AND (t.translation_type = 'SL::DB::PaymentTerm/description_long')|;
1724     my ($description_long, $output_numberformat, $output_dateformat,
1725       $output_longdates) =
1726       selectrow_query($self, $dbh, $query,
1727                       $self->{"language_id"}, $self->{"payment_id"});
1728
1729     $self->{payment_terms} = $description_long if ($description_long);
1730
1731     if ($output_dateformat) {
1732       foreach my $key (qw(netto_date skonto_date)) {
1733         $self->{$key} =
1734           $main::locale->reformat_date($myconfig, $self->{$key},
1735                                        $output_dateformat,
1736                                        $output_longdates);
1737       }
1738     }
1739
1740     if ($output_numberformat &&
1741         ($output_numberformat ne $myconfig->{"numberformat"})) {
1742       my $saved_numberformat = $myconfig->{"numberformat"};
1743       $myconfig->{"numberformat"} = $output_numberformat;
1744       map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1745       $myconfig->{"numberformat"} = $saved_numberformat;
1746     }
1747   }
1748
1749   $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1750   $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1751   $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1752   $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1753   $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1754   $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1755   $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1756
1757   map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1758
1759   $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1760
1761   $main::lxdebug->leave_sub();
1762
1763 }
1764
1765 sub get_template_language {
1766   $main::lxdebug->enter_sub();
1767
1768   my ($self, $myconfig) = @_;
1769
1770   my $template_code = "";
1771
1772   if ($self->{language_id}) {
1773     my $dbh = $self->get_standard_dbh($myconfig);
1774     my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1775     ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1776   }
1777
1778   $main::lxdebug->leave_sub();
1779
1780   return $template_code;
1781 }
1782
1783 sub get_printer_code {
1784   $main::lxdebug->enter_sub();
1785
1786   my ($self, $myconfig) = @_;
1787
1788   my $template_code = "";
1789
1790   if ($self->{printer_id}) {
1791     my $dbh = $self->get_standard_dbh($myconfig);
1792     my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1793     ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1794   }
1795
1796   $main::lxdebug->leave_sub();
1797
1798   return $template_code;
1799 }
1800
1801 sub get_shipto {
1802   $main::lxdebug->enter_sub();
1803
1804   my ($self, $myconfig) = @_;
1805
1806   my $template_code = "";
1807
1808   if ($self->{shipto_id}) {
1809     my $dbh = $self->get_standard_dbh($myconfig);
1810     my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1811     my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1812     map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1813   }
1814
1815   $main::lxdebug->leave_sub();
1816 }
1817
1818 sub add_shipto {
1819   $main::lxdebug->enter_sub();
1820
1821   my ($self, $dbh, $id, $module) = @_;
1822
1823   my $shipto;
1824   my @values;
1825
1826   foreach my $item (qw(name department_1 department_2 street zipcode city country
1827                        contact cp_gender phone fax email)) {
1828     if ($self->{"shipto$item"}) {
1829       $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1830     }
1831     push(@values, $self->{"shipto${item}"});
1832   }
1833
1834   if ($shipto) {
1835     if ($self->{shipto_id}) {
1836       my $query = qq|UPDATE shipto set
1837                        shiptoname = ?,
1838                        shiptodepartment_1 = ?,
1839                        shiptodepartment_2 = ?,
1840                        shiptostreet = ?,
1841                        shiptozipcode = ?,
1842                        shiptocity = ?,
1843                        shiptocountry = ?,
1844                        shiptocontact = ?,
1845                        shiptocp_gender = ?,
1846                        shiptophone = ?,
1847                        shiptofax = ?,
1848                        shiptoemail = ?
1849                      WHERE shipto_id = ?|;
1850       do_query($self, $dbh, $query, @values, $self->{shipto_id});
1851     } else {
1852       my $query = qq|SELECT * FROM shipto
1853                      WHERE shiptoname = ? AND
1854                        shiptodepartment_1 = ? AND
1855                        shiptodepartment_2 = ? AND
1856                        shiptostreet = ? AND
1857                        shiptozipcode = ? AND
1858                        shiptocity = ? AND
1859                        shiptocountry = ? AND
1860                        shiptocontact = ? AND
1861                        shiptocp_gender = ? AND
1862                        shiptophone = ? AND
1863                        shiptofax = ? AND
1864                        shiptoemail = ? AND
1865                        module = ? AND
1866                        trans_id = ?|;
1867       my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
1868       if(!$insert_check){
1869         $query =
1870           qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
1871                                  shiptostreet, shiptozipcode, shiptocity, shiptocountry,
1872                                  shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
1873              VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
1874         do_query($self, $dbh, $query, $id, @values, $module);
1875       }
1876     }
1877   }
1878
1879   $main::lxdebug->leave_sub();
1880 }
1881
1882 sub get_employee {
1883   $main::lxdebug->enter_sub();
1884
1885   my ($self, $dbh) = @_;
1886
1887   $dbh ||= $self->get_standard_dbh(\%main::myconfig);
1888
1889   my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
1890   ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
1891   $self->{"employee_id"} *= 1;
1892
1893   $main::lxdebug->leave_sub();
1894 }
1895
1896 sub get_employee_data {
1897   $main::lxdebug->enter_sub();
1898
1899   my $self     = shift;
1900   my %params   = @_;
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     map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
1918
1919     $self->{$params{prefix} . '_login'}   = $login;
1920     $self->{$params{prefix} . '_name'}  ||= $login;
1921   }
1922
1923   $main::lxdebug->leave_sub();
1924 }
1925
1926 sub get_duedate {
1927   $main::lxdebug->enter_sub();
1928
1929   my ($self, $myconfig, $reference_date) = @_;
1930
1931   $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
1932
1933   my $dbh         = $self->get_standard_dbh($myconfig);
1934   my ($payment_id, $duedate);
1935
1936   if($self->{payment_id}) {
1937     $payment_id = $self->{payment_id};
1938   } elsif($self->{vendor_id}) {
1939     my $query = 'SELECT payment_id FROM vendor WHERE id = ?';
1940     ($payment_id) = selectrow_query($self, $dbh, $query, $self->{vendor_id});
1941   }
1942
1943   if ($payment_id) {
1944     my $query  = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
1945     ($duedate) = selectrow_query($self, $dbh, $query, $payment_id);
1946   }
1947
1948   $main::lxdebug->leave_sub();
1949
1950   return $duedate;
1951 }
1952
1953 sub _get_contacts {
1954   $main::lxdebug->enter_sub();
1955
1956   my ($self, $dbh, $id, $key) = @_;
1957
1958   $key = "all_contacts" unless ($key);
1959
1960   if (!$id) {
1961     $self->{$key} = [];
1962     $main::lxdebug->leave_sub();
1963     return;
1964   }
1965
1966   my $query =
1967     qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
1968     qq|FROM contacts | .
1969     qq|WHERE cp_cv_id = ? | .
1970     qq|ORDER BY lower(cp_name)|;
1971
1972   $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
1973
1974   $main::lxdebug->leave_sub();
1975 }
1976
1977 sub _get_projects {
1978   $main::lxdebug->enter_sub();
1979
1980   my ($self, $dbh, $key) = @_;
1981
1982   my ($all, $old_id, $where, @values);
1983
1984   if (ref($key) eq "HASH") {
1985     my $params = $key;
1986
1987     $key = "ALL_PROJECTS";
1988
1989     foreach my $p (keys(%{$params})) {
1990       if ($p eq "all") {
1991         $all = $params->{$p};
1992       } elsif ($p eq "old_id") {
1993         $old_id = $params->{$p};
1994       } elsif ($p eq "key") {
1995         $key = $params->{$p};
1996       }
1997     }
1998   }
1999
2000   if (!$all) {
2001     $where = "WHERE active ";
2002     if ($old_id) {
2003       if (ref($old_id) eq "ARRAY") {
2004         my @ids = grep({ $_ } @{$old_id});
2005         if (@ids) {
2006           $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2007           push(@values, @ids);
2008         }
2009       } else {
2010         $where .= " OR (id = ?) ";
2011         push(@values, $old_id);
2012       }
2013     }
2014   }
2015
2016   my $query =
2017     qq|SELECT id, projectnumber, description, active | .
2018     qq|FROM project | .
2019     $where .
2020     qq|ORDER BY lower(projectnumber)|;
2021
2022   $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2023
2024   $main::lxdebug->leave_sub();
2025 }
2026
2027 sub _get_shipto {
2028   $main::lxdebug->enter_sub();
2029
2030   my ($self, $dbh, $vc_id, $key) = @_;
2031
2032   $key = "all_shipto" unless ($key);
2033
2034   if ($vc_id) {
2035     # get shipping addresses
2036     my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2037
2038     $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2039
2040   } else {
2041     $self->{$key} = [];
2042   }
2043
2044   $main::lxdebug->leave_sub();
2045 }
2046
2047 sub _get_printers {
2048   $main::lxdebug->enter_sub();
2049
2050   my ($self, $dbh, $key) = @_;
2051
2052   $key = "all_printers" unless ($key);
2053
2054   my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2055
2056   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2057
2058   $main::lxdebug->leave_sub();
2059 }
2060
2061 sub _get_charts {
2062   $main::lxdebug->enter_sub();
2063
2064   my ($self, $dbh, $params) = @_;
2065   my ($key);
2066
2067   $key = $params->{key};
2068   $key = "all_charts" unless ($key);
2069
2070   my $transdate = quote_db_date($params->{transdate});
2071
2072   my $query =
2073     qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2074     qq|FROM chart c | .
2075     qq|LEFT JOIN taxkeys tk ON | .
2076     qq|(tk.id = (SELECT id FROM taxkeys | .
2077     qq|          WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2078     qq|          ORDER BY startdate DESC LIMIT 1)) | .
2079     qq|ORDER BY c.accno|;
2080
2081   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2082
2083   $main::lxdebug->leave_sub();
2084 }
2085
2086 sub _get_taxcharts {
2087   $main::lxdebug->enter_sub();
2088
2089   my ($self, $dbh, $params) = @_;
2090
2091   my $key = "all_taxcharts";
2092   my @where;
2093
2094   if (ref $params eq 'HASH') {
2095     $key = $params->{key} if ($params->{key});
2096     if ($params->{module} eq 'AR') {
2097       push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2098
2099     } elsif ($params->{module} eq 'AP') {
2100       push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2101     }
2102
2103   } elsif ($params) {
2104     $key = $params;
2105   }
2106
2107   my $where = @where ? ' WHERE ' . join(' AND ', map { "($_)" } @where) : '';
2108
2109   my $query = qq|SELECT * FROM tax $where ORDER BY taxkey, rate|;
2110
2111   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2112
2113   $main::lxdebug->leave_sub();
2114 }
2115
2116 sub _get_taxzones {
2117   $main::lxdebug->enter_sub();
2118
2119   my ($self, $dbh, $key) = @_;
2120
2121   $key = "all_taxzones" unless ($key);
2122
2123   my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2124
2125   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2126
2127   $main::lxdebug->leave_sub();
2128 }
2129
2130 sub _get_employees {
2131   $main::lxdebug->enter_sub();
2132
2133   my ($self, $dbh, $default_key, $key) = @_;
2134
2135   $key = $default_key unless ($key);
2136   $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2137
2138   $main::lxdebug->leave_sub();
2139 }
2140
2141 sub _get_business_types {
2142   $main::lxdebug->enter_sub();
2143
2144   my ($self, $dbh, $key) = @_;
2145
2146   my $options       = ref $key eq 'HASH' ? $key : { key => $key };
2147   $options->{key} ||= "all_business_types";
2148   my $where         = '';
2149
2150   if (exists $options->{salesman}) {
2151     $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2152   }
2153
2154   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2155
2156   $main::lxdebug->leave_sub();
2157 }
2158
2159 sub _get_languages {
2160   $main::lxdebug->enter_sub();
2161
2162   my ($self, $dbh, $key) = @_;
2163
2164   $key = "all_languages" unless ($key);
2165
2166   my $query = qq|SELECT * FROM language ORDER BY id|;
2167
2168   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2169
2170   $main::lxdebug->leave_sub();
2171 }
2172
2173 sub _get_dunning_configs {
2174   $main::lxdebug->enter_sub();
2175
2176   my ($self, $dbh, $key) = @_;
2177
2178   $key = "all_dunning_configs" unless ($key);
2179
2180   my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2181
2182   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2183
2184   $main::lxdebug->leave_sub();
2185 }
2186
2187 sub _get_currencies {
2188 $main::lxdebug->enter_sub();
2189
2190   my ($self, $dbh, $key) = @_;
2191
2192   $key = "all_currencies" unless ($key);
2193
2194   $self->{$key} = [$self->get_all_currencies()];
2195
2196   $main::lxdebug->leave_sub();
2197 }
2198
2199 sub _get_payments {
2200 $main::lxdebug->enter_sub();
2201
2202   my ($self, $dbh, $key) = @_;
2203
2204   $key = "all_payments" unless ($key);
2205
2206   my $query = qq|SELECT * FROM payment_terms ORDER BY sortkey|;
2207
2208   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2209
2210   $main::lxdebug->leave_sub();
2211 }
2212
2213 sub _get_customers {
2214   $main::lxdebug->enter_sub();
2215
2216   my ($self, $dbh, $key) = @_;
2217
2218   my $options        = ref $key eq 'HASH' ? $key : { key => $key };
2219   $options->{key}  ||= "all_customers";
2220   my $limit_clause   = $options->{limit} ? "LIMIT $options->{limit}" : '';
2221
2222   my @where;
2223   push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if  $options->{business_is_salesman};
2224   push @where, qq|NOT obsolete|                                            if !$options->{with_obsolete};
2225   my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2226
2227   my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2228   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2229
2230   $main::lxdebug->leave_sub();
2231 }
2232
2233 sub _get_vendors {
2234   $main::lxdebug->enter_sub();
2235
2236   my ($self, $dbh, $key) = @_;
2237
2238   $key = "all_vendors" unless ($key);
2239
2240   my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2241
2242   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2243
2244   $main::lxdebug->leave_sub();
2245 }
2246
2247 sub _get_departments {
2248   $main::lxdebug->enter_sub();
2249
2250   my ($self, $dbh, $key) = @_;
2251
2252   $key = "all_departments" unless ($key);
2253
2254   my $query = qq|SELECT * FROM department ORDER BY description|;
2255
2256   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2257
2258   $main::lxdebug->leave_sub();
2259 }
2260
2261 sub _get_warehouses {
2262   $main::lxdebug->enter_sub();
2263
2264   my ($self, $dbh, $param) = @_;
2265
2266   my ($key, $bins_key);
2267
2268   if ('' eq ref $param) {
2269     $key = $param;
2270
2271   } else {
2272     $key      = $param->{key};
2273     $bins_key = $param->{bins};
2274   }
2275
2276   my $query = qq|SELECT w.* FROM warehouse w
2277                  WHERE (NOT w.invalid) AND
2278                    ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2279                  ORDER BY w.sortkey|;
2280
2281   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2282
2283   if ($bins_key) {
2284     $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?
2285                 ORDER BY description|;
2286     my $sth = prepare_query($self, $dbh, $query);
2287
2288     foreach my $warehouse (@{ $self->{$key} }) {
2289       do_statement($self, $sth, $query, $warehouse->{id});
2290       $warehouse->{$bins_key} = [];
2291
2292       while (my $ref = $sth->fetchrow_hashref()) {
2293         push @{ $warehouse->{$bins_key} }, $ref;
2294       }
2295     }
2296     $sth->finish();
2297   }
2298
2299   $main::lxdebug->leave_sub();
2300 }
2301
2302 sub _get_simple {
2303   $main::lxdebug->enter_sub();
2304
2305   my ($self, $dbh, $table, $key, $sortkey) = @_;
2306
2307   my $query  = qq|SELECT * FROM $table|;
2308   $query    .= qq| ORDER BY $sortkey| if ($sortkey);
2309
2310   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2311
2312   $main::lxdebug->leave_sub();
2313 }
2314
2315 #sub _get_groups {
2316 #  $main::lxdebug->enter_sub();
2317 #
2318 #  my ($self, $dbh, $key) = @_;
2319 #
2320 #  $key ||= "all_groups";
2321 #
2322 #  my $groups = $main::auth->read_groups();
2323 #
2324 #  $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2325 #
2326 #  $main::lxdebug->leave_sub();
2327 #}
2328
2329 sub get_lists {
2330   $main::lxdebug->enter_sub();
2331
2332   my $self = shift;
2333   my %params = @_;
2334
2335   my $dbh = $self->get_standard_dbh(\%main::myconfig);
2336   my ($sth, $query, $ref);
2337
2338   my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2339   my $vc_id = $self->{"${vc}_id"};
2340
2341   if ($params{"contacts"}) {
2342     $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2343   }
2344
2345   if ($params{"shipto"}) {
2346     $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2347   }
2348
2349   if ($params{"projects"} || $params{"all_projects"}) {
2350     $self->_get_projects($dbh, $params{"all_projects"} ?
2351                          $params{"all_projects"} : $params{"projects"},
2352                          $params{"all_projects"} ? 1 : 0);
2353   }
2354
2355   if ($params{"printers"}) {
2356     $self->_get_printers($dbh, $params{"printers"});
2357   }
2358
2359   if ($params{"languages"}) {
2360     $self->_get_languages($dbh, $params{"languages"});
2361   }
2362
2363   if ($params{"charts"}) {
2364     $self->_get_charts($dbh, $params{"charts"});
2365   }
2366
2367   if ($params{"taxcharts"}) {
2368     $self->_get_taxcharts($dbh, $params{"taxcharts"});
2369   }
2370
2371   if ($params{"taxzones"}) {
2372     $self->_get_taxzones($dbh, $params{"taxzones"});
2373   }
2374
2375   if ($params{"employees"}) {
2376     $self->_get_employees($dbh, "all_employees", $params{"employees"});
2377   }
2378
2379   if ($params{"salesmen"}) {
2380     $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2381   }
2382
2383   if ($params{"business_types"}) {
2384     $self->_get_business_types($dbh, $params{"business_types"});
2385   }
2386
2387   if ($params{"dunning_configs"}) {
2388     $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2389   }
2390
2391   if($params{"currencies"}) {
2392     $self->_get_currencies($dbh, $params{"currencies"});
2393   }
2394
2395   if($params{"customers"}) {
2396     $self->_get_customers($dbh, $params{"customers"});
2397   }
2398
2399   if($params{"vendors"}) {
2400     if (ref $params{"vendors"} eq 'HASH') {
2401       $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2402     } else {
2403       $self->_get_vendors($dbh, $params{"vendors"});
2404     }
2405   }
2406
2407   if($params{"payments"}) {
2408     $self->_get_payments($dbh, $params{"payments"});
2409   }
2410
2411   if($params{"departments"}) {
2412     $self->_get_departments($dbh, $params{"departments"});
2413   }
2414
2415   if ($params{price_factors}) {
2416     $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2417   }
2418
2419   if ($params{warehouses}) {
2420     $self->_get_warehouses($dbh, $params{warehouses});
2421   }
2422
2423 #  if ($params{groups}) {
2424 #    $self->_get_groups($dbh, $params{groups});
2425 #  }
2426
2427   if ($params{partsgroup}) {
2428     $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2429   }
2430
2431   $main::lxdebug->leave_sub();
2432 }
2433
2434 # this sub gets the id and name from $table
2435 sub get_name {
2436   $main::lxdebug->enter_sub();
2437
2438   my ($self, $myconfig, $table) = @_;
2439
2440   # connect to database
2441   my $dbh = $self->get_standard_dbh($myconfig);
2442
2443   $table = $table eq "customer" ? "customer" : "vendor";
2444   my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2445
2446   my ($query, @values);
2447
2448   if (!$self->{openinvoices}) {
2449     my $where;
2450     if ($self->{customernumber} ne "") {
2451       $where = qq|(vc.customernumber ILIKE ?)|;
2452       push(@values, '%' . $self->{customernumber} . '%');
2453     } else {
2454       $where = qq|(vc.name ILIKE ?)|;
2455       push(@values, '%' . $self->{$table} . '%');
2456     }
2457
2458     $query =
2459       qq~SELECT vc.id, vc.name,
2460            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2461          FROM $table vc
2462          WHERE $where AND (NOT vc.obsolete)
2463          ORDER BY vc.name~;
2464   } else {
2465     $query =
2466       qq~SELECT DISTINCT vc.id, vc.name,
2467            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2468          FROM $arap a
2469          JOIN $table vc ON (a.${table}_id = vc.id)
2470          WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2471          ORDER BY vc.name~;
2472     push(@values, '%' . $self->{$table} . '%');
2473   }
2474
2475   $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2476
2477   $main::lxdebug->leave_sub();
2478
2479   return scalar(@{ $self->{name_list} });
2480 }
2481
2482 # the selection sub is used in the AR, AP, IS, IR, DO and OE module
2483 #
2484 sub all_vc {
2485   $main::lxdebug->enter_sub();
2486
2487   my ($self, $myconfig, $table, $module) = @_;
2488
2489   my $ref;
2490   my $dbh = $self->get_standard_dbh;
2491
2492   $table = $table eq "customer" ? "customer" : "vendor";
2493
2494   # build selection list
2495   # Hotfix für Bug 1837 - Besser wäre es alte Buchungsbelege
2496   # OHNE Auswahlliste (reines Textfeld) zu laden. Hilft aber auch
2497   # nicht für veränderbare Belege (oe, do, ...)
2498   my $obsolete = $self->{id} ? '' : "WHERE NOT obsolete";
2499   my $query = qq|SELECT count(*) FROM $table $obsolete|;
2500   my ($count) = selectrow_query($self, $dbh, $query);
2501
2502   if ($count <= $myconfig->{vclimit}) {
2503     $query = qq|SELECT id, name, salesman_id
2504                 FROM $table $obsolete
2505                 ORDER BY name|;
2506     $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2507   }
2508
2509   # get self
2510   $self->get_employee($dbh);
2511
2512   # setup sales contacts
2513   $query = qq|SELECT e.id, e.name
2514               FROM employee e
2515               WHERE (e.sales = '1') AND (NOT e.id = ?)
2516               ORDER BY name|;
2517   $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2518
2519   # this is for self
2520   push(@{ $self->{all_employees} },
2521        { id   => $self->{employee_id},
2522          name => $self->{employee} });
2523
2524     # prepare query for departments
2525     $query = qq|SELECT id, description
2526                 FROM department
2527                 ORDER BY description|;
2528
2529   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2530
2531   # get languages
2532   $query = qq|SELECT id, description
2533               FROM language
2534               ORDER BY id|;
2535
2536   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2537
2538   # get printer
2539   $query = qq|SELECT printer_description, id
2540               FROM printers
2541               ORDER BY printer_description|;
2542
2543   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2544
2545   # get payment terms
2546   $query = qq|SELECT id, description
2547               FROM payment_terms
2548               ORDER BY sortkey|;
2549
2550   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2551
2552   $main::lxdebug->leave_sub();
2553 }
2554
2555 sub language_payment {
2556   $main::lxdebug->enter_sub();
2557
2558   my ($self, $myconfig) = @_;
2559
2560   my $dbh = $self->get_standard_dbh($myconfig);
2561   # get languages
2562   my $query = qq|SELECT id, description
2563                  FROM language
2564                  ORDER BY id|;
2565
2566   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2567
2568   # get printer
2569   $query = qq|SELECT printer_description, id
2570               FROM printers
2571               ORDER BY printer_description|;
2572
2573   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2574
2575   # get payment terms
2576   $query = qq|SELECT id, description
2577               FROM payment_terms
2578               ORDER BY sortkey|;
2579
2580   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2581
2582   # get buchungsgruppen
2583   $query = qq|SELECT id, description
2584               FROM buchungsgruppen|;
2585
2586   $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2587
2588   $main::lxdebug->leave_sub();
2589 }
2590
2591 # this is only used for reports
2592 sub all_departments {
2593   $main::lxdebug->enter_sub();
2594
2595   my ($self, $myconfig, $table) = @_;
2596
2597   my $dbh = $self->get_standard_dbh($myconfig);
2598
2599   my $query = qq|SELECT id, description
2600                  FROM department
2601                  ORDER BY description|;
2602   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2603
2604   delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2605
2606   $main::lxdebug->leave_sub();
2607 }
2608
2609 sub create_links {
2610   $main::lxdebug->enter_sub();
2611
2612   my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2613
2614   my ($fld, $arap);
2615   if ($table eq "customer") {
2616     $fld = "buy";
2617     $arap = "ar";
2618   } else {
2619     $table = "vendor";
2620     $fld = "sell";
2621     $arap = "ap";
2622   }
2623
2624   $self->all_vc($myconfig, $table, $module);
2625
2626   # get last customers or vendors
2627   my ($query, $sth, $ref);
2628
2629   my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2630   my %xkeyref = ();
2631
2632   if (!$self->{id}) {
2633
2634     my $transdate = "current_date";
2635     if ($self->{transdate}) {
2636       $transdate = $dbh->quote($self->{transdate});
2637     }
2638
2639     # now get the account numbers
2640 #    $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2641 #                FROM chart c, taxkeys tk
2642 #                WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2643 #                  (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2644 #                ORDER BY c.accno|;
2645
2646 #  same query as above, but without expensive subquery for each row. about 80% faster
2647     $query = qq|
2648       SELECT c.accno, c.description, c.link, c.taxkey_id, tk2.tax_id
2649         FROM chart c
2650         -- find newest entries in taxkeys
2651         INNER JOIN (
2652           SELECT chart_id, MAX(startdate) AS startdate
2653           FROM taxkeys
2654           WHERE (startdate <= $transdate)
2655           GROUP BY chart_id
2656         ) tk ON (c.id = tk.chart_id)
2657         -- and load all of those entries
2658         INNER JOIN taxkeys tk2
2659            ON (tk.chart_id = tk2.chart_id AND tk.startdate = tk2.startdate)
2660        WHERE (c.link LIKE ?)
2661       ORDER BY c.accno|;
2662
2663     $sth = $dbh->prepare($query);
2664
2665     do_statement($self, $sth, $query, '%' . $module . '%');
2666
2667     $self->{accounts} = "";
2668     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2669
2670       foreach my $key (split(/:/, $ref->{link})) {
2671         if ($key =~ /\Q$module\E/) {
2672
2673           # cross reference for keys
2674           $xkeyref{ $ref->{accno} } = $key;
2675
2676           push @{ $self->{"${module}_links"}{$key} },
2677             { accno       => $ref->{accno},
2678               description => $ref->{description},
2679               taxkey      => $ref->{taxkey_id},
2680               tax_id      => $ref->{tax_id} };
2681
2682           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2683         }
2684       }
2685     }
2686   }
2687
2688   # get taxkeys and description
2689   $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2690   $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2691
2692   if (($module eq "AP") || ($module eq "AR")) {
2693     # get tax rates and description
2694     $query = qq|SELECT * FROM tax|;
2695     $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2696   }
2697
2698   my $extra_columns = '';
2699   $extra_columns   .= 'a.direct_debit, ' if ($module eq 'AR') || ($module eq 'AP');
2700
2701   if ($self->{id}) {
2702     $query =
2703       qq|SELECT
2704            a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2705            a.duedate, a.ordnumber, a.taxincluded, (SELECT cu.name FROM currencies cu WHERE cu.id=a.currency_id) AS currency, a.notes,
2706            a.intnotes, a.department_id, a.amount AS oldinvtotal,
2707            a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2708            a.globalproject_id, ${extra_columns}
2709            c.name AS $table,
2710            d.description AS department,
2711            e.name AS employee
2712          FROM $arap a
2713          JOIN $table c ON (a.${table}_id = c.id)
2714          LEFT JOIN employee e ON (e.id = a.employee_id)
2715          LEFT JOIN department d ON (d.id = a.department_id)
2716          WHERE a.id = ?|;
2717     $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2718
2719     foreach my $key (keys %$ref) {
2720       $self->{$key} = $ref->{$key};
2721     }
2722
2723     my $transdate = "current_date";
2724     if ($self->{transdate}) {
2725       $transdate = $dbh->quote($self->{transdate});
2726     }
2727
2728     # now get the account numbers
2729     $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2730                 FROM chart c
2731                 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2732                 WHERE c.link LIKE ?
2733                   AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2734                     OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2735                 ORDER BY c.accno|;
2736
2737     $sth = $dbh->prepare($query);
2738     do_statement($self, $sth, $query, "%$module%");
2739
2740     $self->{accounts} = "";
2741     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2742
2743       foreach my $key (split(/:/, $ref->{link})) {
2744         if ($key =~ /\Q$module\E/) {
2745
2746           # cross reference for keys
2747           $xkeyref{ $ref->{accno} } = $key;
2748
2749           push @{ $self->{"${module}_links"}{$key} },
2750             { accno       => $ref->{accno},
2751               description => $ref->{description},
2752               taxkey      => $ref->{taxkey_id},
2753               tax_id      => $ref->{tax_id} };
2754
2755           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2756         }
2757       }
2758     }
2759
2760
2761     # get amounts from individual entries
2762     $query =
2763       qq|SELECT
2764            c.accno, c.description,
2765            a.acc_trans_id, a.source, a.amount, a.memo, a.transdate, a.gldate, a.cleared, a.project_id, a.taxkey,
2766            p.projectnumber,
2767            t.rate, t.id
2768          FROM acc_trans a
2769          LEFT JOIN chart c ON (c.id = a.chart_id)
2770          LEFT JOIN project p ON (p.id = a.project_id)
2771          LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2772                                     WHERE (tk.taxkey_id=a.taxkey) AND
2773                                       ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2774                                         THEN tk.chart_id = a.chart_id
2775                                         ELSE 1 = 1
2776                                         END)
2777                                        OR (c.link='%tax%')) AND
2778                                       (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2779          WHERE a.trans_id = ?
2780          AND a.fx_transaction = '0'
2781          ORDER BY a.acc_trans_id, a.transdate|;
2782     $sth = $dbh->prepare($query);
2783     do_statement($self, $sth, $query, $self->{id});
2784
2785     # get exchangerate for currency
2786     $self->{exchangerate} =
2787       $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2788     my $index = 0;
2789
2790     # store amounts in {acc_trans}{$key} for multiple accounts
2791     while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2792       $ref->{exchangerate} =
2793         $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2794       if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2795         $index++;
2796       }
2797       if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2798         $ref->{amount} *= -1;
2799       }
2800       $ref->{index} = $index;
2801
2802       push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2803     }
2804
2805     $sth->finish;
2806     #check das:
2807     $query =
2808       qq|SELECT
2809            d.closedto, d.revtrans,
2810            (SELECT cu.name FROM currencies cu WHERE cu.id=d.currency_id) AS defaultcurrency,
2811            (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2812            (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2813          FROM defaults d|;
2814     $ref = selectfirst_hashref_query($self, $dbh, $query);
2815     map { $self->{$_} = $ref->{$_} } keys %$ref;
2816
2817   } else {
2818
2819     # get date
2820     $query =
2821        qq|SELECT
2822             current_date AS transdate, d.closedto, d.revtrans,
2823             (SELECT cu.name FROM currencies cu WHERE cu.id=d.currency_id) AS defaultcurrency,
2824             (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2825             (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2826           FROM defaults d|;
2827     $ref = selectfirst_hashref_query($self, $dbh, $query);
2828     map { $self->{$_} = $ref->{$_} } keys %$ref;
2829
2830     if ($self->{"$self->{vc}_id"}) {
2831
2832       # only setup currency
2833       ($self->{currency}) = $self->{defaultcurrency} if !$self->{currency};
2834
2835     } else {
2836
2837       $self->lastname_used($dbh, $myconfig, $table, $module);
2838
2839       # get exchangerate for currency
2840       $self->{exchangerate} =
2841         $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2842
2843     }
2844
2845   }
2846
2847   $main::lxdebug->leave_sub();
2848 }
2849
2850 sub lastname_used {
2851   $main::lxdebug->enter_sub();
2852
2853   my ($self, $dbh, $myconfig, $table, $module) = @_;
2854
2855   my ($arap, $where);
2856
2857   $table         = $table eq "customer" ? "customer" : "vendor";
2858   my %column_map = ("a.${table}_id"           => "${table}_id",
2859                     "a.department_id"         => "department_id",
2860                     "d.description"           => "department",
2861                     "ct.name"                 => $table,
2862                     "cu.name"                 => "currency",
2863                     "current_date + ct.terms" => "duedate",
2864     );
2865
2866   if ($self->{type} =~ /delivery_order/) {
2867     $arap  = 'delivery_orders';
2868     delete $column_map{"cu.currency"};
2869
2870   } elsif ($self->{type} =~ /_order/) {
2871     $arap  = 'oe';
2872     $where = "quotation = '0'";
2873
2874   } elsif ($self->{type} =~ /_quotation/) {
2875     $arap  = 'oe';
2876     $where = "quotation = '1'";
2877
2878   } elsif ($table eq 'customer') {
2879     $arap  = 'ar';
2880
2881   } else {
2882     $arap  = 'ap';
2883
2884   }
2885
2886   $where           = "($where) AND" if ($where);
2887   my $query        = qq|SELECT MAX(id) FROM $arap
2888                         WHERE $where ${table}_id > 0|;
2889   my ($trans_id)   = selectrow_query($self, $dbh, $query);
2890   $trans_id       *= 1;
2891
2892   my $column_spec  = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
2893   $query           = qq|SELECT $column_spec
2894                         FROM $arap a
2895                         LEFT JOIN $table     ct ON (a.${table}_id = ct.id)
2896                         LEFT JOIN department d  ON (a.department_id = d.id)
2897                         LEFT JOIN currencies cu ON (cu.id=ct.currency_id)
2898                         WHERE a.id = ?|;
2899   my $ref          = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
2900
2901   map { $self->{$_} = $ref->{$_} } values %column_map;
2902
2903   $main::lxdebug->leave_sub();
2904 }
2905
2906 sub current_date {
2907   $main::lxdebug->enter_sub();
2908
2909   my $self     = shift;
2910   my $myconfig = shift || \%::myconfig;
2911   my ($thisdate, $days) = @_;
2912
2913   my $dbh = $self->get_standard_dbh($myconfig);
2914   my $query;
2915
2916   $days *= 1;
2917   if ($thisdate) {
2918     my $dateformat = $myconfig->{dateformat};
2919     $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
2920     $thisdate = $dbh->quote($thisdate);
2921     $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
2922   } else {
2923     $query = qq|SELECT current_date AS thisdate|;
2924   }
2925
2926   ($thisdate) = selectrow_query($self, $dbh, $query);
2927
2928   $main::lxdebug->leave_sub();
2929
2930   return $thisdate;
2931 }
2932
2933 sub like {
2934   $main::lxdebug->enter_sub();
2935
2936   my ($self, $string) = @_;
2937
2938   if ($string !~ /%/) {
2939     $string = "%$string%";
2940   }
2941
2942   $string =~ s/\'/\'\'/g;
2943
2944   $main::lxdebug->leave_sub();
2945
2946   return $string;
2947 }
2948
2949 sub redo_rows {
2950   $main::lxdebug->enter_sub();
2951
2952   my ($self, $flds, $new, $count, $numrows) = @_;
2953
2954   my @ndx = ();
2955
2956   map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
2957
2958   my $i = 0;
2959
2960   # fill rows
2961   foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
2962     $i++;
2963     my $j = $item->{ndx} - 1;
2964     map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
2965   }
2966
2967   # delete empty rows
2968   for $i ($count + 1 .. $numrows) {
2969     map { delete $self->{"${_}_$i"} } @{$flds};
2970   }
2971
2972   $main::lxdebug->leave_sub();
2973 }
2974
2975 sub update_status {
2976   $main::lxdebug->enter_sub();
2977
2978   my ($self, $myconfig) = @_;
2979
2980   my ($i, $id);
2981
2982   my $dbh = $self->dbconnect_noauto($myconfig);
2983
2984   my $query = qq|DELETE FROM status
2985                  WHERE (formname = ?) AND (trans_id = ?)|;
2986   my $sth = prepare_query($self, $dbh, $query);
2987
2988   if ($self->{formname} =~ /(check|receipt)/) {
2989     for $i (1 .. $self->{rowcount}) {
2990       do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
2991     }
2992   } else {
2993     do_statement($self, $sth, $query, $self->{formname}, $self->{id});
2994   }
2995   $sth->finish();
2996
2997   my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
2998   my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
2999
3000   my %queued = split / /, $self->{queued};
3001   my @values;
3002
3003   if ($self->{formname} =~ /(check|receipt)/) {
3004
3005     # this is a check or receipt, add one entry for each lineitem
3006     my ($accno) = split /--/, $self->{account};
3007     $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3008                 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3009     @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3010     $sth = prepare_query($self, $dbh, $query);
3011
3012     for $i (1 .. $self->{rowcount}) {
3013       if ($self->{"checked_$i"}) {
3014         do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3015       }
3016     }
3017     $sth->finish();
3018
3019   } else {
3020     $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3021                 VALUES (?, ?, ?, ?, ?)|;
3022     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3023              $queued{$self->{formname}}, $self->{formname});
3024   }
3025
3026   $dbh->commit;
3027   $dbh->disconnect;
3028
3029   $main::lxdebug->leave_sub();
3030 }
3031
3032 sub save_status {
3033   $main::lxdebug->enter_sub();
3034
3035   my ($self, $dbh) = @_;
3036
3037   my ($query, $printed, $emailed);
3038
3039   my $formnames  = $self->{printed};
3040   my $emailforms = $self->{emailed};
3041
3042   $query = qq|DELETE FROM status
3043                  WHERE (formname = ?) AND (trans_id = ?)|;
3044   do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3045
3046   # this only applies to the forms
3047   # checks and receipts are posted when printed or queued
3048
3049   if ($self->{queued}) {
3050     my %queued = split / /, $self->{queued};
3051
3052     foreach my $formname (keys %queued) {
3053       $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3054       $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3055
3056       $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3057                   VALUES (?, ?, ?, ?, ?)|;
3058       do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3059
3060       $formnames  =~ s/\Q$self->{formname}\E//;
3061       $emailforms =~ s/\Q$self->{formname}\E//;
3062
3063     }
3064   }
3065
3066   # save printed, emailed info
3067   $formnames  =~ s/^ +//g;
3068   $emailforms =~ s/^ +//g;
3069
3070   my %status = ();
3071   map { $status{$_}{printed} = 1 } split / +/, $formnames;
3072   map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3073
3074   foreach my $formname (keys %status) {
3075     $printed = ($formnames  =~ /\Q$self->{formname}\E/) ? "1" : "0";
3076     $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3077
3078     $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3079                 VALUES (?, ?, ?, ?)|;
3080     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3081   }
3082
3083   $main::lxdebug->leave_sub();
3084 }
3085
3086 #--- 4 locale ---#
3087 # $main::locale->text('SAVED')
3088 # $main::locale->text('DELETED')
3089 # $main::locale->text('ADDED')
3090 # $main::locale->text('PAYMENT POSTED')
3091 # $main::locale->text('POSTED')
3092 # $main::locale->text('POSTED AS NEW')
3093 # $main::locale->text('ELSE')
3094 # $main::locale->text('SAVED FOR DUNNING')
3095 # $main::locale->text('DUNNING STARTED')
3096 # $main::locale->text('PRINTED')
3097 # $main::locale->text('MAILED')
3098 # $main::locale->text('SCREENED')
3099 # $main::locale->text('CANCELED')
3100 # $main::locale->text('invoice')
3101 # $main::locale->text('proforma')
3102 # $main::locale->text('sales_order')
3103 # $main::locale->text('pick_list')
3104 # $main::locale->text('purchase_order')
3105 # $main::locale->text('bin_list')
3106 # $main::locale->text('sales_quotation')
3107 # $main::locale->text('request_quotation')
3108
3109 sub save_history {
3110   $main::lxdebug->enter_sub();
3111
3112   my $self = shift;
3113   my $dbh  = shift || $self->get_standard_dbh;
3114
3115   if(!exists $self->{employee_id}) {
3116     &get_employee($self, $dbh);
3117   }
3118
3119   my $query =
3120    qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3121    qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3122   my @values = (conv_i($self->{id}), $self->{login},
3123                 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3124   do_query($self, $dbh, $query, @values);
3125
3126   $dbh->commit;
3127
3128   $main::lxdebug->leave_sub();
3129 }
3130
3131 sub get_history {
3132   $main::lxdebug->enter_sub();
3133
3134   my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3135   my ($orderBy, $desc) = split(/\-\-/, $order);
3136   $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3137   my @tempArray;
3138   my $i = 0;
3139   if ($trans_id ne "") {
3140     my $query =
3141       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 | .
3142       qq|FROM history_erp h | .
3143       qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3144       qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3145       $order;
3146
3147     my $sth = $dbh->prepare($query) || $self->dberror($query);
3148
3149     $sth->execute() || $self->dberror("$query");
3150
3151     while(my $hash_ref = $sth->fetchrow_hashref()) {
3152       $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3153       $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3154       $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3155       $tempArray[$i++] = $hash_ref;
3156     }
3157     $main::lxdebug->leave_sub() and return \@tempArray
3158       if ($i > 0 && $tempArray[0] ne "");
3159   }
3160   $main::lxdebug->leave_sub();
3161   return 0;
3162 }
3163
3164 sub update_defaults {
3165   $main::lxdebug->enter_sub();
3166
3167   my ($self, $myconfig, $fld, $provided_dbh) = @_;
3168
3169   my $dbh;
3170   if ($provided_dbh) {
3171     $dbh = $provided_dbh;
3172   } else {
3173     $dbh = $self->dbconnect_noauto($myconfig);
3174   }
3175   my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3176   my $sth   = $dbh->prepare($query);
3177
3178   $sth->execute || $self->dberror($query);
3179   my ($var) = $sth->fetchrow_array;
3180   $sth->finish;
3181
3182   $var   = 0 if !defined($var) || ($var eq '');
3183   $var   = SL::PrefixedNumber->new(number => $var)->get_next;
3184   $query = qq|UPDATE defaults SET $fld = ?|;
3185   do_query($self, $dbh, $query, $var);
3186
3187   if (!$provided_dbh) {
3188     $dbh->commit;
3189     $dbh->disconnect;
3190   }
3191
3192   $main::lxdebug->leave_sub();
3193
3194   return $var;
3195 }
3196
3197 sub update_business {
3198   $main::lxdebug->enter_sub();
3199
3200   my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3201
3202   my $dbh;
3203   if ($provided_dbh) {
3204     $dbh = $provided_dbh;
3205   } else {
3206     $dbh = $self->dbconnect_noauto($myconfig);
3207   }
3208   my $query =
3209     qq|SELECT customernumberinit FROM business
3210        WHERE id = ? FOR UPDATE|;
3211   my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3212
3213   return undef unless $var;
3214
3215   if ($var =~ m/\d+$/) {
3216     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3217     my $len_diff = length($var) - $-[0] - length($new_var);
3218     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3219
3220   } else {
3221     $var = $var . '1';
3222   }
3223
3224   $query = qq|UPDATE business
3225               SET customernumberinit = ?
3226               WHERE id = ?|;
3227   do_query($self, $dbh, $query, $var, $business_id);
3228
3229   if (!$provided_dbh) {
3230     $dbh->commit;
3231     $dbh->disconnect;
3232   }
3233
3234   $main::lxdebug->leave_sub();
3235
3236   return $var;
3237 }
3238
3239 sub get_partsgroup {
3240   $main::lxdebug->enter_sub();
3241
3242   my ($self, $myconfig, $p) = @_;
3243   my $target = $p->{target} || 'all_partsgroup';
3244
3245   my $dbh = $self->get_standard_dbh($myconfig);
3246
3247   my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3248                  FROM partsgroup pg
3249                  JOIN parts p ON (p.partsgroup_id = pg.id) |;
3250   my @values;
3251
3252   if ($p->{searchitems} eq 'part') {
3253     $query .= qq|WHERE p.inventory_accno_id > 0|;
3254   }
3255   if ($p->{searchitems} eq 'service') {
3256     $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3257   }
3258   if ($p->{searchitems} eq 'assembly') {
3259     $query .= qq|WHERE p.assembly = '1'|;
3260   }
3261   if ($p->{searchitems} eq 'labor') {
3262     $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3263   }
3264
3265   $query .= qq|ORDER BY partsgroup|;
3266
3267   if ($p->{all}) {
3268     $query = qq|SELECT id, partsgroup FROM partsgroup
3269                 ORDER BY partsgroup|;
3270   }
3271
3272   if ($p->{language_code}) {
3273     $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3274                   t.description AS translation
3275                 FROM partsgroup pg
3276                 JOIN parts p ON (p.partsgroup_id = pg.id)
3277                 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3278                 ORDER BY translation|;
3279     @values = ($p->{language_code});
3280   }
3281
3282   $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3283
3284   $main::lxdebug->leave_sub();
3285 }
3286
3287 sub get_pricegroup {
3288   $main::lxdebug->enter_sub();
3289
3290   my ($self, $myconfig, $p) = @_;
3291
3292   my $dbh = $self->get_standard_dbh($myconfig);
3293
3294   my $query = qq|SELECT p.id, p.pricegroup
3295                  FROM pricegroup p|;
3296
3297   $query .= qq| ORDER BY pricegroup|;
3298
3299   if ($p->{all}) {
3300     $query = qq|SELECT id, pricegroup FROM pricegroup
3301                 ORDER BY pricegroup|;
3302   }
3303
3304   $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3305
3306   $main::lxdebug->leave_sub();
3307 }
3308
3309 sub all_years {
3310 # usage $form->all_years($myconfig, [$dbh])
3311 # return list of all years where bookings found
3312 # (@all_years)
3313
3314   $main::lxdebug->enter_sub();
3315
3316   my ($self, $myconfig, $dbh) = @_;
3317
3318   $dbh ||= $self->get_standard_dbh($myconfig);
3319
3320   # get years
3321   my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3322                    (SELECT MAX(transdate) FROM acc_trans)|;
3323   my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3324
3325   if ($myconfig->{dateformat} =~ /^yy/) {
3326     ($startdate) = split /\W/, $startdate;
3327     ($enddate) = split /\W/, $enddate;
3328   } else {
3329     (@_) = split /\W/, $startdate;
3330     $startdate = $_[2];
3331     (@_) = split /\W/, $enddate;
3332     $enddate = $_[2];
3333   }
3334
3335   my @all_years;
3336   $startdate = substr($startdate,0,4);
3337   $enddate = substr($enddate,0,4);
3338
3339   while ($enddate >= $startdate) {
3340     push @all_years, $enddate--;
3341   }
3342
3343   return @all_years;
3344
3345   $main::lxdebug->leave_sub();
3346 }
3347
3348 sub backup_vars {
3349   $main::lxdebug->enter_sub();
3350   my $self = shift;
3351   my @vars = @_;
3352
3353   map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3354
3355   $main::lxdebug->leave_sub();
3356 }
3357
3358 sub restore_vars {
3359   $main::lxdebug->enter_sub();
3360
3361   my $self = shift;
3362   my @vars = @_;
3363
3364   map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3365
3366   $main::lxdebug->leave_sub();
3367 }
3368
3369 sub prepare_for_printing {
3370   my ($self) = @_;
3371
3372   my $defaults         = SL::DB::Default->get;
3373
3374   $self->{templates} ||= $defaults->templates;
3375   $self->{formname}  ||= $self->{type};
3376   $self->{media}     ||= 'email';
3377
3378   die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3379
3380   # set shipto from billto unless set
3381   my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3382   if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3383     $self->{shiptoname}   = $::myconfig{company};
3384     $self->{shiptostreet} = $::myconfig{address};
3385   }
3386
3387   my $language = $self->{language} ? '_' . $self->{language} : '';
3388
3389   my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3390   if ($self->{language_id}) {
3391     ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3392   } else {
3393     $output_dateformat   = $::myconfig{dateformat};
3394     $output_numberformat = $::myconfig{numberformat};
3395     $output_longdates    = 1;
3396   }
3397
3398   # Retrieve accounts for tax calculation.
3399   IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3400
3401   if ($self->{type} =~ /_delivery_order$/) {
3402     DO->order_details(\%::myconfig, $self);
3403   } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3404     OE->order_details(\%::myconfig, $self);
3405   } else {
3406     IS->invoice_details(\%::myconfig, $self, $::locale);
3407   }
3408
3409   # Chose extension & set source file name
3410   my $extension = 'html';
3411   if ($self->{format} eq 'postscript') {
3412     $self->{postscript}   = 1;
3413     $extension            = 'tex';
3414   } elsif ($self->{"format"} =~ /pdf/) {
3415     $self->{pdf}          = 1;
3416     $extension            = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3417   } elsif ($self->{"format"} =~ /opendocument/) {
3418     $self->{opendocument} = 1;
3419     $extension            = 'odt';
3420   } elsif ($self->{"format"} =~ /excel/) {
3421     $self->{excel}        = 1;
3422     $extension            = 'xls';
3423   }
3424
3425   my $printer_code    = $self->{printer_code} ? '_' . $self->{printer_code} : '';
3426   my $email_extension = -f ($defaults->templates . "/$self->{formname}_email${language}.${extension}") ? '_email' : '';
3427   $self->{IN}         = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3428
3429   # Format dates.
3430   $self->format_dates($output_dateformat, $output_longdates,
3431                       qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3432                          transdate_oe deliverydate_oe employee_startdate employee_enddate),
3433                       grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3434
3435   $self->reformat_numbers($output_numberformat, 2,
3436                           qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3437                           grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3438
3439   $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3440
3441   my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3442
3443   if (scalar @{ $cvar_date_fields }) {
3444     $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3445   }
3446
3447   while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3448     $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3449   }
3450
3451   return $self;
3452 }
3453
3454 sub format_dates {
3455   my ($self, $dateformat, $longformat, @indices) = @_;
3456
3457   $dateformat ||= $::myconfig{dateformat};
3458
3459   foreach my $idx (@indices) {
3460     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3461       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3462         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3463       }
3464     }
3465
3466     next unless defined $self->{$idx};
3467
3468     if (!ref($self->{$idx})) {
3469       $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3470
3471     } elsif (ref($self->{$idx}) eq "ARRAY") {
3472       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3473         $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3474       }
3475     }
3476   }
3477 }
3478
3479 sub reformat_numbers {
3480   my ($self, $numberformat, $places, @indices) = @_;
3481
3482   return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3483
3484   foreach my $idx (@indices) {
3485     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3486       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3487         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3488       }
3489     }
3490
3491     next unless defined $self->{$idx};
3492
3493     if (!ref($self->{$idx})) {
3494       $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3495
3496     } elsif (ref($self->{$idx}) eq "ARRAY") {
3497       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3498         $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3499       }
3500     }
3501   }
3502
3503   my $saved_numberformat    = $::myconfig{numberformat};
3504   $::myconfig{numberformat} = $numberformat;
3505
3506   foreach my $idx (@indices) {
3507     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3508       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3509         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3510       }
3511     }
3512
3513     next unless defined $self->{$idx};
3514
3515     if (!ref($self->{$idx})) {
3516       $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3517
3518     } elsif (ref($self->{$idx}) eq "ARRAY") {
3519       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3520         $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3521       }
3522     }
3523   }
3524
3525   $::myconfig{numberformat} = $saved_numberformat;
3526 }
3527
3528 sub layout {
3529   my ($self) = @_;
3530   $::lxdebug->enter_sub;
3531
3532   my %style_to_script_map = (
3533     v3  => 'v3',
3534     neu => 'new',
3535   );
3536
3537   my $menu_script = $style_to_script_map{$::myconfig{menustyle}} || '';
3538
3539   package main;
3540   require "bin/mozilla/menu$menu_script.pl";
3541   package Form;
3542   require SL::Controller::FrameHeader;
3543
3544
3545   my $layout = SL::Controller::FrameHeader->new->action_header . ::render();
3546
3547   $::lxdebug->leave_sub;
3548   return $layout;
3549 }
3550
3551 1;
3552
3553 __END__
3554
3555 =head1 NAME
3556
3557 SL::Form.pm - main data object.
3558
3559 =head1 SYNOPSIS
3560
3561 This is the main data object of kivitendo.
3562 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3563 Points of interest for a beginner are:
3564
3565  - $form->error            - renders a generic error in html. accepts an error message
3566  - $form->get_standard_dbh - returns a database connection for the
3567
3568 =head1 SPECIAL FUNCTIONS
3569
3570 =head2 C<update_business> PARAMS
3571
3572 PARAMS (not named):
3573  \%config,     - config hashref
3574  $business_id, - business id
3575  $dbh          - optional database handle
3576
3577 handles business (thats customer/vendor types) sequences.
3578
3579 special behaviour for empty strings in customerinitnumber field:
3580 will in this case not increase the value, and return undef.
3581
3582 =head2 C<redirect_header> $url
3583
3584 Generates a HTTP redirection header for the new C<$url>. Constructs an
3585 absolute URL including scheme, host name and port. If C<$url> is a
3586 relative URL then it is considered relative to kivitendo base URL.
3587
3588 This function C<die>s if headers have already been created with
3589 C<$::form-E<gt>header>.
3590
3591 Examples:
3592
3593   print $::form->redirect_header('oe.pl?action=edit&id=1234');
3594   print $::form->redirect_header('http://www.lx-office.org/');
3595
3596 =head2 C<header>
3597
3598 Generates a general purpose http/html header and includes most of the scripts
3599 and stylesheets needed. Stylesheets can be added with L<use_stylesheet>.
3600
3601 Only one header will be generated. If the method was already called in this
3602 request it will not output anything and return undef. Also if no
3603 HTTP_USER_AGENT is found, no header is generated.
3604
3605 Although header does not accept parameters itself, it will honor special
3606 hashkeys of its Form instance:
3607
3608 =over 4
3609
3610 =item refresh_time
3611
3612 =item refresh_url
3613
3614 If one of these is set, a http-equiv refresh is generated. Missing parameters
3615 default to 3 seconds and the refering url.
3616
3617 =item stylesheet
3618
3619 Either a scalar or an array ref. Will be inlined into the header. Add
3620 stylesheets with the L<use_stylesheet> function.
3621
3622 =item landscape
3623
3624 If true, a css snippet will be generated that sets the page in landscape mode.
3625
3626 =item favicon
3627
3628 Used to override the default favicon.
3629
3630 =item title
3631
3632 A html page title will be generated from this
3633
3634 =back
3635
3636 =cut