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 $defaults  = SL::DB::Default->get;
 982   my $userspath = $::lx_office_conf{paths}->{userspath};
 983
 984   $self->{"cwd"} = getcwd();
 985   $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
 986
 987   my $ext_for_format;
 988
 989   my $template_type;
 990   if ($self->{"format"} =~ /(opendocument|oasis)/i) {
 991     $template_type  = 'OpenDocument';
 992     $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
 993
 994   } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
 995     $template_type    = 'LaTeX';
 996     $ext_for_format   = 'pdf';
 997
 998   } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
 999     $template_type  = 'HTML';
1000     $ext_for_format = 'html';
1001
1002   } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1003     $template_type  = 'XML';
1004     $ext_for_format = 'xml';
1005
1006   } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1007     $template_type = 'XML';
1008
1009   } elsif ( $self->{"format"} =~ /excel/i ) {
1010     $template_type  = 'Excel';
1011     $ext_for_format = 'xls';
1012
1013   } elsif ( defined $self->{'format'}) {
1014     $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1015
1016   } elsif ( $self->{'format'} eq '' ) {
1017     $self->error("No Outputformat given: $self->{'format'}");
1018
1019   } else { #Catch the rest
1020     $self->error("Outputformat not defined: $self->{'format'}");
1021   }
1022
1023   my $template = SL::Template::create(type      => $template_type,
1024                                       file_name => $self->{IN},
1025                                       form      => $self,
1026                                       myconfig  => $myconfig,
1027                                       userspath => $userspath);
1028
1029   # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1030   $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1031
1032   if (!$self->{employee_id}) {
1033     $self->{"employee_${_}"} = $myconfig->{$_} for qw(email tel fax name signature);
1034     $self->{"employee_${_}"} = $defaults->$_   for qw(address businessnumber co_ustid company duns sepa_creditor_id taxnumber);
1035   }
1036
1037   $self->{"myconfig_${_}"} = $myconfig->{$_} for grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1038   $self->{$_}              = $defaults->$_   for qw(co_ustid);
1039   $self->{"myconfig_${_}"} = $defaults->$_   for qw(address businessnumber co_ustid company duns sepa_creditor_id taxnumber);
1040
1041   $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1042
1043   # OUT is used for the media, screen, printer, email
1044   # for postscript we store a copy in a temporary file
1045   my ($temp_fh, $suffix);
1046   $suffix =  $self->{IN};
1047   $suffix =~ s/.*\.//;
1048   ($temp_fh, $self->{tmpfile}) = File::Temp::tempfile(
1049     'kivitendo-printXXXXXX',
1050     SUFFIX => '.' . ($suffix || 'tex'),
1051     DIR    => $userspath,
1052     UNLINK => ($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})? 0 : 1,
1053   );
1054   close $temp_fh;
1055   (undef, undef, $self->{template_meta}{tmpfile}) = File::Spec->splitpath( $self->{tmpfile} );
1056
1057   if ($template->uses_temp_file() || $self->{media} eq 'email') {
1058     $out              = $self->{OUT};
1059     $out_mode         = $self->{OUT_MODE} || '>';
1060     $self->{OUT}      = "$self->{tmpfile}";
1061     $self->{OUT_MODE} = '>';
1062   }
1063
1064   my $result;
1065   my $command_formatter = sub {
1066     my ($out_mode, $out) = @_;
1067     return $out_mode eq '|-' ? SL::Template::create(type => 'ShellCommand', form => $self)->parse($out) : $out;
1068   };
1069
1070   if ($self->{OUT}) {
1071     $self->{OUT} = $command_formatter->($self->{OUT_MODE}, $self->{OUT});
1072     open(OUT, $self->{OUT_MODE}, $self->{OUT}) or $self->error("error on opening $self->{OUT} with mode $self->{OUT_MODE} : $!");
1073   } else {
1074     *OUT = ($::dispatcher->get_standard_filehandles)[1];
1075     $self->header;
1076   }
1077
1078   if (!$template->parse(*OUT)) {
1079     $self->cleanup();
1080     $self->error("$self->{IN} : " . $template->get_error());
1081   }
1082
1083   close OUT if $self->{OUT};
1084
1085   if ($self->{media} eq 'file') {
1086     copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1087     $self->cleanup;
1088     chdir("$self->{cwd}");
1089
1090     $::lxdebug->leave_sub();
1091
1092     return;
1093   }
1094
1095   if ($template->uses_temp_file() || $self->{media} eq 'email') {
1096
1097     if ($self->{media} eq 'email') {
1098
1099       my $mail = new Mailer;
1100
1101       map { $mail->{$_} = $self->{$_} }
1102         qw(cc bcc subject message version format);
1103       $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1104       $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1105       $mail->{from}   = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1106       $mail->{fileid} = time() . '.' . $$ . '.';
1107       $myconfig->{signature} =~ s/\r//g;
1108
1109       # if we send html or plain text inline
1110       if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1111         $mail->{contenttype}    =  "text/html";
1112         $mail->{message}        =~ s/\r//g;
1113         $mail->{message}        =~ s/\n/<br>\n/g;
1114         $myconfig->{signature}  =~ s/\n/<br>\n/g;
1115         $mail->{message}       .=  "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1116
1117         open(IN, "<", $self->{tmpfile})
1118           or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1119         $mail->{message} .= $_ while <IN>;
1120         close(IN);
1121
1122       } else {
1123
1124         if (!$self->{"do_not_attach"}) {
1125           my $attachment_name  =  $self->{attachment_filename} || $self->{tmpfile};
1126           $attachment_name     =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1127           $mail->{attachments} =  [{ "filename" => $self->{tmpfile},
1128                                      "name"     => $attachment_name }];
1129         }
1130
1131         $mail->{message}  =~ s/\r//g;
1132         $mail->{message} .=  "\n-- \n$myconfig->{signature}";
1133
1134       }
1135
1136       my $err = $mail->send();
1137       $self->error($self->cleanup . "$err") if ($err);
1138
1139     } else {
1140
1141       $self->{OUT}      = $out;
1142       $self->{OUT_MODE} = $out_mode;
1143
1144       my $numbytes = (-s $self->{tmpfile});
1145       open(IN, "<", $self->{tmpfile})
1146         or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1147       binmode IN;
1148
1149       $self->{copies} = 1 unless $self->{media} eq 'printer';
1150
1151       chdir("$self->{cwd}");
1152       #print(STDERR "Kopien $self->{copies}\n");
1153       #print(STDERR "OUT $self->{OUT}\n");
1154       for my $i (1 .. $self->{copies}) {
1155         if ($self->{OUT}) {
1156           $self->{OUT} = $command_formatter->($self->{OUT_MODE}, $self->{OUT});
1157
1158           open  OUT, $self->{OUT_MODE}, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1159           print OUT $_ while <IN>;
1160           close OUT;
1161           seek  IN, 0, 0;
1162
1163         } else {
1164           $self->{attachment_filename} = ($self->{attachment_filename})
1165                                        ? $self->{attachment_filename}
1166                                        : $self->generate_attachment_filename();
1167
1168           # launch application
1169           print qq|Content-Type: | . $template->get_mime_type() . qq|
1170 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1171 Content-Length: $numbytes
1172
1173 |;
1174
1175           $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1176         }
1177       }
1178
1179       close(IN);
1180     }
1181
1182   }
1183
1184   $self->cleanup;
1185
1186   chdir("$self->{cwd}");
1187   $main::lxdebug->leave_sub();
1188 }
1189
1190 sub get_formname_translation {
1191   $main::lxdebug->enter_sub();
1192   my ($self, $formname) = @_;
1193
1194   $formname ||= $self->{formname};
1195
1196   $self->{recipient_locale} ||=  Locale->lang_to_locale($self->{language});
1197   local $::locale = Locale->new($self->{recipient_locale});
1198
1199   my %formname_translations = (
1200     bin_list                => $main::locale->text('Bin List'),
1201     credit_note             => $main::locale->text('Credit Note'),
1202     invoice                 => $main::locale->text('Invoice'),
1203     pick_list               => $main::locale->text('Pick List'),
1204     proforma                => $main::locale->text('Proforma Invoice'),
1205     purchase_order          => $main::locale->text('Purchase Order'),
1206     request_quotation       => $main::locale->text('RFQ'),
1207     sales_order             => $main::locale->text('Confirmation'),
1208     sales_quotation         => $main::locale->text('Quotation'),
1209     storno_invoice          => $main::locale->text('Storno Invoice'),
1210     sales_delivery_order    => $main::locale->text('Delivery Order'),
1211     purchase_delivery_order => $main::locale->text('Delivery Order'),
1212     dunning                 => $main::locale->text('Dunning'),
1213   );
1214
1215   $main::lxdebug->leave_sub();
1216   return $formname_translations{$formname};
1217 }
1218
1219 sub get_number_prefix_for_type {
1220   $main::lxdebug->enter_sub();
1221   my ($self) = @_;
1222
1223   my $prefix =
1224       (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1225     : ($self->{type} =~ /_quotation$/)                        ? 'quo'
1226     : ($self->{type} =~ /_delivery_order$/)                   ? 'do'
1227     :                                                           'ord';
1228
1229   $main::lxdebug->leave_sub();
1230   return $prefix;
1231 }
1232
1233 sub get_extension_for_format {
1234   $main::lxdebug->enter_sub();
1235   my ($self)    = @_;
1236
1237   my $extension = $self->{format} =~ /pdf/i          ? ".pdf"
1238                 : $self->{format} =~ /postscript/i   ? ".ps"
1239                 : $self->{format} =~ /opendocument/i ? ".odt"
1240                 : $self->{format} =~ /excel/i        ? ".xls"
1241                 : $self->{format} =~ /html/i         ? ".html"
1242                 :                                      "";
1243
1244   $main::lxdebug->leave_sub();
1245   return $extension;
1246 }
1247
1248 sub generate_attachment_filename {
1249   $main::lxdebug->enter_sub();
1250   my ($self) = @_;
1251
1252   $self->{recipient_locale} ||=  Locale->lang_to_locale($self->{language});
1253   my $recipient_locale = Locale->new($self->{recipient_locale});
1254
1255   my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1256   my $prefix              = $self->get_number_prefix_for_type();
1257
1258   if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1259     $attachment_filename .= ' (' . $recipient_locale->text('Preview') . ')' . $self->get_extension_for_format();
1260
1261   } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1262     $attachment_filename .=  "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1263
1264   } else {
1265     $attachment_filename = "";
1266   }
1267
1268   $attachment_filename =  $main::locale->quote_special_chars('filenames', $attachment_filename);
1269   $attachment_filename =~ s|[\s/\\]+|_|g;
1270
1271   $main::lxdebug->leave_sub();
1272   return $attachment_filename;
1273 }
1274
1275 sub generate_email_subject {
1276   $main::lxdebug->enter_sub();
1277   my ($self) = @_;
1278
1279   my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1280   my $prefix  = $self->get_number_prefix_for_type();
1281
1282   if ($subject && $self->{"${prefix}number"}) {
1283     $subject .= " " . $self->{"${prefix}number"}
1284   }
1285
1286   $main::lxdebug->leave_sub();
1287   return $subject;
1288 }
1289
1290 sub cleanup {
1291   $main::lxdebug->enter_sub();
1292
1293   my ($self, $application) = @_;
1294
1295   my $error_code = $?;
1296
1297   chdir("$self->{tmpdir}");
1298
1299   my @err = ();
1300   if ((-1 == $error_code) || (127 == (($error_code) >> 8))) {
1301     push @err, $::locale->text('The application "#1" was not found on the system.', $application || 'pdflatex') . ' ' . $::locale->text('Please contact your administrator.');
1302
1303   } elsif (-f "$self->{tmpfile}.err") {
1304     open(FH, "$self->{tmpfile}.err");
1305     @err = <FH>;
1306     close(FH);
1307   }
1308
1309   if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1310     $self->{tmpfile} =~ s|.*/||g;
1311     # strip extension
1312     $self->{tmpfile} =~ s/\.\w+$//g;
1313     my $tmpfile = $self->{tmpfile};
1314     unlink(<$tmpfile.*>);
1315   }
1316
1317   chdir("$self->{cwd}");
1318
1319   $main::lxdebug->leave_sub();
1320
1321   return "@err";
1322 }
1323
1324 sub datetonum {
1325   $main::lxdebug->enter_sub();
1326
1327   my ($self, $date, $myconfig) = @_;
1328   my ($yy, $mm, $dd);
1329
1330   if ($date && $date =~ /\D/) {
1331
1332     if ($myconfig->{dateformat} =~ /^yy/) {
1333       ($yy, $mm, $dd) = split /\D/, $date;
1334     }
1335     if ($myconfig->{dateformat} =~ /^mm/) {
1336       ($mm, $dd, $yy) = split /\D/, $date;
1337     }
1338     if ($myconfig->{dateformat} =~ /^dd/) {
1339       ($dd, $mm, $yy) = split /\D/, $date;
1340     }
1341
1342     $dd *= 1;
1343     $mm *= 1;
1344     $yy = ($yy < 70) ? $yy + 2000 : $yy;
1345     $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1346
1347     $dd = "0$dd" if ($dd < 10);
1348     $mm = "0$mm" if ($mm < 10);
1349
1350     $date = "$yy$mm$dd";
1351   }
1352
1353   $main::lxdebug->leave_sub();
1354
1355   return $date;
1356 }
1357
1358 # Database routines used throughout
1359
1360 sub dbconnect {
1361   $main::lxdebug->enter_sub(2);
1362
1363   my ($self, $myconfig) = @_;
1364
1365   # connect to database
1366   my $dbh = SL::DBConnect->connect or $self->dberror;
1367
1368   # set db options
1369   if ($myconfig->{dboptions}) {
1370     $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1371   }
1372
1373   $main::lxdebug->leave_sub(2);
1374
1375   return $dbh;
1376 }
1377
1378 sub dbconnect_noauto {
1379   $main::lxdebug->enter_sub();
1380
1381   my ($self, $myconfig) = @_;
1382
1383   # connect to database
1384   my $dbh = SL::DBConnect->connect(SL::DBConnect->get_connect_args(AutoCommit => 0)) or $self->dberror;
1385
1386   # set db options
1387   if ($myconfig->{dboptions}) {
1388     $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1389   }
1390
1391   $main::lxdebug->leave_sub();
1392
1393   return $dbh;
1394 }
1395
1396 sub get_standard_dbh {
1397   $main::lxdebug->enter_sub(2);
1398
1399   my $self     = shift;
1400   my $myconfig = shift || \%::myconfig;
1401
1402   if ($standard_dbh && !$standard_dbh->{Active}) {
1403     $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1404     undef $standard_dbh;
1405   }
1406
1407   $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1408
1409   $main::lxdebug->leave_sub(2);
1410
1411   return $standard_dbh;
1412 }
1413
1414 sub date_closed {
1415   $main::lxdebug->enter_sub();
1416
1417   my ($self, $date, $myconfig) = @_;
1418   my $dbh = $self->dbconnect($myconfig);
1419
1420   my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1421   my $sth = prepare_execute_query($self, $dbh, $query, conv_date($date));
1422
1423   # Falls $date = '' - Fehlermeldung aus der Datenbank. Ich denke,
1424   # es ist sicher ein conv_date vorher IMMER auszuführen.
1425   # Testfälle ohne definiertes closedto:
1426   #   Leere Datumseingabe i.O.
1427   #     SELECT 1 FROM defaults WHERE '' < closedto
1428   #   normale Zahlungsbuchung über Rechnungsmaske i.O.
1429   #     SELECT 1 FROM defaults WHERE '10.05.2011' < closedto
1430   # Testfälle mit definiertem closedto (30.04.2011):
1431   #  Leere Datumseingabe i.O.
1432   #   SELECT 1 FROM defaults WHERE '' < closedto
1433   # normale Buchung im geschloßenem Zeitraum i.O.
1434   #   SELECT 1 FROM defaults WHERE '21.04.2011' < closedto
1435   #     Fehlermeldung: Es können keine Zahlungen für abgeschlossene Bücher gebucht werden!
1436   # normale Buchung in aktiver Buchungsperiode i.O.
1437   #   SELECT 1 FROM defaults WHERE '01.05.2011' < closedto
1438
1439   my ($closed) = $sth->fetchrow_array;
1440
1441   $main::lxdebug->leave_sub();
1442
1443   return $closed;
1444 }
1445
1446 # prevents bookings to the to far away future
1447 sub date_max_future {
1448   $main::lxdebug->enter_sub();
1449
1450   my ($self, $date, $myconfig) = @_;
1451   my $dbh = $self->dbconnect($myconfig);
1452
1453   my $query = "SELECT 1 FROM defaults WHERE ? - current_date > max_future_booking_interval";
1454   my $sth = prepare_execute_query($self, $dbh, $query, conv_date($date));
1455
1456   my ($max_future_booking_interval) = $sth->fetchrow_array;
1457
1458   $main::lxdebug->leave_sub();
1459
1460   return $max_future_booking_interval;
1461 }
1462
1463
1464 sub update_balance {
1465   $main::lxdebug->enter_sub();
1466
1467   my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1468
1469   # if we have a value, go do it
1470   if ($value != 0) {
1471
1472     # retrieve balance from table
1473     my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1474     my $sth = prepare_execute_query($self, $dbh, $query, @values);
1475     my ($balance) = $sth->fetchrow_array;
1476     $sth->finish;
1477
1478     $balance += $value;
1479
1480     # update balance
1481     $query = "UPDATE $table SET $field = $balance WHERE $where";
1482     do_query($self, $dbh, $query, @values);
1483   }
1484   $main::lxdebug->leave_sub();
1485 }
1486
1487 sub update_exchangerate {
1488   $main::lxdebug->enter_sub();
1489
1490   my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1491   my ($query);
1492   # some sanity check for currency
1493   if ($curr eq '') {
1494     $main::lxdebug->leave_sub();
1495     return;
1496   }
1497   $query = qq|SELECT name AS curr FROM currencies WHERE id=(SELECT currency_id FROM defaults)|;
1498
1499   my ($defaultcurrency) = selectrow_query($self, $dbh, $query);
1500
1501   if ($curr eq $defaultcurrency) {
1502     $main::lxdebug->leave_sub();
1503     return;
1504   }
1505
1506   $query = qq|SELECT e.currency_id FROM exchangerate e
1507                  WHERE e.currency_id = (SELECT cu.id FROM currencies cu WHERE cu.name=?) AND e.transdate = ?
1508                  FOR UPDATE|;
1509   my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1510
1511   if ($buy == 0) {
1512     $buy = "";
1513   }
1514   if ($sell == 0) {
1515     $sell = "";
1516   }
1517
1518   $buy = conv_i($buy, "NULL");
1519   $sell = conv_i($sell, "NULL");
1520
1521   my $set;
1522   if ($buy != 0 && $sell != 0) {
1523     $set = "buy = $buy, sell = $sell";
1524   } elsif ($buy != 0) {
1525     $set = "buy = $buy";
1526   } elsif ($sell != 0) {
1527     $set = "sell = $sell";
1528   }
1529
1530   if ($sth->fetchrow_array) {
1531     $query = qq|UPDATE exchangerate
1532                 SET $set
1533                 WHERE currency_id = (SELECT id FROM currencies WHERE name = ?)
1534                 AND transdate = ?|;
1535
1536   } else {
1537     $query = qq|INSERT INTO exchangerate (currency_id, buy, sell, transdate)
1538                 VALUES ((SELECT id FROM currencies WHERE name = ?), $buy, $sell, ?)|;
1539   }
1540   $sth->finish;
1541   do_query($self, $dbh, $query, $curr, $transdate);
1542
1543   $main::lxdebug->leave_sub();
1544 }
1545
1546 sub save_exchangerate {
1547   $main::lxdebug->enter_sub();
1548
1549   my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1550
1551   my $dbh = $self->dbconnect($myconfig);
1552
1553   my ($buy, $sell);
1554
1555   $buy  = $rate if $fld eq 'buy';
1556   $sell = $rate if $fld eq 'sell';
1557
1558
1559   $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1560
1561
1562   $dbh->disconnect;
1563
1564   $main::lxdebug->leave_sub();
1565 }
1566
1567 sub get_exchangerate {
1568   $main::lxdebug->enter_sub();
1569
1570   my ($self, $dbh, $curr, $transdate, $fld) = @_;
1571   my ($query);
1572
1573   unless ($transdate && $curr) {
1574     $main::lxdebug->leave_sub();
1575     return 1;
1576   }
1577
1578   $query = qq|SELECT name AS curr FROM currencies WHERE id = (SELECT currency_id FROM defaults)|;
1579
1580   my ($defaultcurrency) = selectrow_query($self, $dbh, $query);
1581
1582   if ($curr eq $defaultcurrency) {
1583     $main::lxdebug->leave_sub();
1584     return 1;
1585   }
1586
1587   $query = qq|SELECT e.$fld FROM exchangerate e
1588                  WHERE e.currency_id = (SELECT id FROM currencies WHERE name = ?) AND e.transdate = ?|;
1589   my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1590
1591
1592
1593   $main::lxdebug->leave_sub();
1594
1595   return $exchangerate;
1596 }
1597
1598 sub check_exchangerate {
1599   $main::lxdebug->enter_sub();
1600
1601   my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1602
1603   if ($fld !~/^buy|sell$/) {
1604     $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1605   }
1606
1607   unless ($transdate) {
1608     $main::lxdebug->leave_sub();
1609     return "";
1610   }
1611
1612   my ($defaultcurrency) = $self->get_default_currency($myconfig);
1613
1614   if ($currency eq $defaultcurrency) {
1615     $main::lxdebug->leave_sub();
1616     return 1;
1617   }
1618
1619   my $dbh   = $self->get_standard_dbh($myconfig);
1620   my $query = qq|SELECT e.$fld FROM exchangerate e
1621                  WHERE e.currency_id = (SELECT id FROM currencies WHERE name = ?) AND e.transdate = ?|;
1622
1623   my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1624
1625   $main::lxdebug->leave_sub();
1626
1627   return $exchangerate;
1628 }
1629
1630 sub get_all_currencies {
1631   $main::lxdebug->enter_sub();
1632
1633   my $self     = shift;
1634   my $myconfig = shift || \%::myconfig;
1635   my $dbh      = $self->get_standard_dbh($myconfig);
1636
1637   my $query = qq|SELECT name FROM currencies|;
1638   my @currencies = map { $_->{name} } selectall_hashref_query($self, $dbh, $query);
1639
1640   $main::lxdebug->leave_sub();
1641
1642   return @currencies;
1643 }
1644
1645 sub get_default_currency {
1646   $main::lxdebug->enter_sub();
1647
1648   my ($self, $myconfig) = @_;
1649   my $dbh      = $self->get_standard_dbh($myconfig);
1650   my $query = qq|SELECT name AS curr FROM currencies WHERE id = (SELECT currency_id FROM defaults)|;
1651
1652   my ($defaultcurrency) = selectrow_query($self, $dbh, $query);
1653
1654   $main::lxdebug->leave_sub();
1655
1656   return $defaultcurrency;
1657 }
1658
1659 sub set_payment_options {
1660   $main::lxdebug->enter_sub();
1661
1662   my ($self, $myconfig, $transdate) = @_;
1663
1664   return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1665
1666   my $dbh = $self->get_standard_dbh($myconfig);
1667
1668   my $query =
1669     qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long , p.description | .
1670     qq|FROM payment_terms p | .
1671     qq|WHERE p.id = ?|;
1672
1673   ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1674    $self->{payment_terms}, $self->{payment_description}) =
1675      selectrow_query($self, $dbh, $query, $self->{payment_id});
1676
1677   if ($transdate eq "") {
1678     if ($self->{invdate}) {
1679       $transdate = $self->{invdate};
1680     } else {
1681       $transdate = $self->{transdate};
1682     }
1683   }
1684
1685   $query =
1686     qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1687     qq|FROM payment_terms|;
1688   ($self->{netto_date}, $self->{skonto_date}) =
1689     selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1690
1691   my ($invtotal, $total);
1692   my (%amounts, %formatted_amounts);
1693
1694   if ($self->{type} =~ /_order$/) {
1695     $amounts{invtotal} = $self->{ordtotal};
1696     $amounts{total}    = $self->{ordtotal};
1697
1698   } elsif ($self->{type} =~ /_quotation$/) {
1699     $amounts{invtotal} = $self->{quototal};
1700     $amounts{total}    = $self->{quototal};
1701
1702   } else {
1703     $amounts{invtotal} = $self->{invtotal};
1704     $amounts{total}    = $self->{total};
1705   }
1706   map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1707
1708   $amounts{skonto_in_percent}  = 100.0 * $self->{percent_skonto};
1709   $amounts{skonto_amount}      = $amounts{invtotal} * $self->{percent_skonto};
1710   $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1711   $amounts{total_wo_skonto}    = $amounts{total}    * (1 - $self->{percent_skonto});
1712
1713   foreach (keys %amounts) {
1714     $amounts{$_}           = $self->round_amount($amounts{$_}, 2);
1715     $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1716   }
1717
1718   if ($self->{"language_id"}) {
1719     $query =
1720       qq|SELECT t.translation, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1721       qq|FROM generic_translations t | .
1722       qq|LEFT JOIN language l ON t.language_id = l.id | .
1723       qq|WHERE (t.language_id = ?)
1724            AND (t.translation_id = ?)
1725            AND (t.translation_type = 'SL::DB::PaymentTerm/description_long')|;
1726     my ($description_long, $output_numberformat, $output_dateformat,
1727       $output_longdates) =
1728       selectrow_query($self, $dbh, $query,
1729                       $self->{"language_id"}, $self->{"payment_id"});
1730
1731     $self->{payment_terms} = $description_long if ($description_long);
1732
1733     if ($output_dateformat) {
1734       foreach my $key (qw(netto_date skonto_date)) {
1735         $self->{$key} =
1736           $main::locale->reformat_date($myconfig, $self->{$key},
1737                                        $output_dateformat,
1738                                        $output_longdates);
1739       }
1740     }
1741
1742     if ($output_numberformat &&
1743         ($output_numberformat ne $myconfig->{"numberformat"})) {
1744       my $saved_numberformat = $myconfig->{"numberformat"};
1745       $myconfig->{"numberformat"} = $output_numberformat;
1746       map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1747       $myconfig->{"numberformat"} = $saved_numberformat;
1748     }
1749   }
1750
1751   $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1752   $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1753   $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1754   $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1755   $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1756   $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1757   $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1758
1759   map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1760
1761   $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1762
1763   $main::lxdebug->leave_sub();
1764
1765 }
1766
1767 sub get_template_language {
1768   $main::lxdebug->enter_sub();
1769
1770   my ($self, $myconfig) = @_;
1771
1772   my $template_code = "";
1773
1774   if ($self->{language_id}) {
1775     my $dbh = $self->get_standard_dbh($myconfig);
1776     my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1777     ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1778   }
1779
1780   $main::lxdebug->leave_sub();
1781
1782   return $template_code;
1783 }
1784
1785 sub get_printer_code {
1786   $main::lxdebug->enter_sub();
1787
1788   my ($self, $myconfig) = @_;
1789
1790   my $template_code = "";
1791
1792   if ($self->{printer_id}) {
1793     my $dbh = $self->get_standard_dbh($myconfig);
1794     my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1795     ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1796   }
1797
1798   $main::lxdebug->leave_sub();
1799
1800   return $template_code;
1801 }
1802
1803 sub get_shipto {
1804   $main::lxdebug->enter_sub();
1805
1806   my ($self, $myconfig) = @_;
1807
1808   my $template_code = "";
1809
1810   if ($self->{shipto_id}) {
1811     my $dbh = $self->get_standard_dbh($myconfig);
1812     my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1813     my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1814     map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1815   }
1816
1817   $main::lxdebug->leave_sub();
1818 }
1819
1820 sub add_shipto {
1821   $main::lxdebug->enter_sub();
1822
1823   my ($self, $dbh, $id, $module) = @_;
1824
1825   my $shipto;
1826   my @values;
1827
1828   foreach my $item (qw(name department_1 department_2 street zipcode city country
1829                        contact cp_gender phone fax email)) {
1830     if ($self->{"shipto$item"}) {
1831       $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1832     }
1833     push(@values, $self->{"shipto${item}"});
1834   }
1835
1836   if ($shipto) {
1837     if ($self->{shipto_id}) {
1838       my $query = qq|UPDATE shipto set
1839                        shiptoname = ?,
1840                        shiptodepartment_1 = ?,
1841                        shiptodepartment_2 = ?,
1842                        shiptostreet = ?,
1843                        shiptozipcode = ?,
1844                        shiptocity = ?,
1845                        shiptocountry = ?,
1846                        shiptocontact = ?,
1847                        shiptocp_gender = ?,
1848                        shiptophone = ?,
1849                        shiptofax = ?,
1850                        shiptoemail = ?
1851                      WHERE shipto_id = ?|;
1852       do_query($self, $dbh, $query, @values, $self->{shipto_id});
1853     } else {
1854       my $query = qq|SELECT * FROM shipto
1855                      WHERE shiptoname = ? AND
1856                        shiptodepartment_1 = ? AND
1857                        shiptodepartment_2 = ? AND
1858                        shiptostreet = ? AND
1859                        shiptozipcode = ? AND
1860                        shiptocity = ? AND
1861                        shiptocountry = ? AND
1862                        shiptocontact = ? AND
1863                        shiptocp_gender = ? AND
1864                        shiptophone = ? AND
1865                        shiptofax = ? AND
1866                        shiptoemail = ? AND
1867                        module = ? AND
1868                        trans_id = ?|;
1869       my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
1870       if(!$insert_check){
1871         $query =
1872           qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
1873                                  shiptostreet, shiptozipcode, shiptocity, shiptocountry,
1874                                  shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
1875              VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
1876         do_query($self, $dbh, $query, $id, @values, $module);
1877       }
1878     }
1879   }
1880
1881   $main::lxdebug->leave_sub();
1882 }
1883
1884 sub get_employee {
1885   $main::lxdebug->enter_sub();
1886
1887   my ($self, $dbh) = @_;
1888
1889   $dbh ||= $self->get_standard_dbh(\%main::myconfig);
1890
1891   my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
1892   ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
1893   $self->{"employee_id"} *= 1;
1894
1895   $main::lxdebug->leave_sub();
1896 }
1897
1898 sub get_employee_data {
1899   $main::lxdebug->enter_sub();
1900
1901   my $self     = shift;
1902   my %params   = @_;
1903   my $defaults = SL::DB::Default->get;
1904
1905   Common::check_params(\%params, qw(prefix));
1906   Common::check_params_x(\%params, qw(id));
1907
1908   if (!$params{id}) {
1909     $main::lxdebug->leave_sub();
1910     return;
1911   }
1912
1913   my $myconfig = \%main::myconfig;
1914   my $dbh      = $params{dbh} || $self->get_standard_dbh($myconfig);
1915
1916   my ($login)  = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
1917
1918   if ($login) {
1919     my $user = User->new(login => $login);
1920     $self->{$params{prefix} . "_${_}"}    = $user->{$_}   for qw(email fax name signature tel);
1921     $self->{$params{prefix} . "_${_}"}    = $defaults->$_ for qw(address businessnumber co_ustid company duns taxnumber);
1922
1923     $self->{$params{prefix} . '_login'}   = $login;
1924     $self->{$params{prefix} . '_name'}  ||= $login;
1925   }
1926
1927   $main::lxdebug->leave_sub();
1928 }
1929
1930 sub get_duedate {
1931   $main::lxdebug->enter_sub();
1932
1933   my ($self, $myconfig, $reference_date) = @_;
1934
1935   $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
1936
1937   my $dbh         = $self->get_standard_dbh($myconfig);
1938   my ($payment_id, $duedate);
1939
1940   if($self->{payment_id}) {
1941     $payment_id = $self->{payment_id};
1942   } elsif($self->{vendor_id}) {
1943     my $query = 'SELECT payment_id FROM vendor WHERE id = ?';
1944     ($payment_id) = selectrow_query($self, $dbh, $query, $self->{vendor_id});
1945   }
1946
1947   if ($payment_id) {
1948     my $query  = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
1949     ($duedate) = selectrow_query($self, $dbh, $query, $payment_id);
1950   }
1951
1952   $main::lxdebug->leave_sub();
1953
1954   return $duedate;
1955 }
1956
1957 sub _get_contacts {
1958   $main::lxdebug->enter_sub();
1959
1960   my ($self, $dbh, $id, $key) = @_;
1961
1962   $key = "all_contacts" unless ($key);
1963
1964   if (!$id) {
1965     $self->{$key} = [];
1966     $main::lxdebug->leave_sub();
1967     return;
1968   }
1969
1970   my $query =
1971     qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
1972     qq|FROM contacts | .
1973     qq|WHERE cp_cv_id = ? | .
1974     qq|ORDER BY lower(cp_name)|;
1975
1976   $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
1977
1978   $main::lxdebug->leave_sub();
1979 }
1980
1981 sub _get_projects {
1982   $main::lxdebug->enter_sub();
1983
1984   my ($self, $dbh, $key) = @_;
1985
1986   my ($all, $old_id, $where, @values);
1987
1988   if (ref($key) eq "HASH") {
1989     my $params = $key;
1990
1991     $key = "ALL_PROJECTS";
1992
1993     foreach my $p (keys(%{$params})) {
1994       if ($p eq "all") {
1995         $all = $params->{$p};
1996       } elsif ($p eq "old_id") {
1997         $old_id = $params->{$p};
1998       } elsif ($p eq "key") {
1999         $key = $params->{$p};
2000       }
2001     }
2002   }
2003
2004   if (!$all) {
2005     $where = "WHERE active ";
2006     if ($old_id) {
2007       if (ref($old_id) eq "ARRAY") {
2008         my @ids = grep({ $_ } @{$old_id});
2009         if (@ids) {
2010           $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2011           push(@values, @ids);
2012         }
2013       } else {
2014         $where .= " OR (id = ?) ";
2015         push(@values, $old_id);
2016       }
2017     }
2018   }
2019
2020   my $query =
2021     qq|SELECT id, projectnumber, description, active | .
2022     qq|FROM project | .
2023     $where .
2024     qq|ORDER BY lower(projectnumber)|;
2025
2026   $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2027
2028   $main::lxdebug->leave_sub();
2029 }
2030
2031 sub _get_shipto {
2032   $main::lxdebug->enter_sub();
2033
2034   my ($self, $dbh, $vc_id, $key) = @_;
2035
2036   $key = "all_shipto" unless ($key);
2037
2038   if ($vc_id) {
2039     # get shipping addresses
2040     my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2041
2042     $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2043
2044   } else {
2045     $self->{$key} = [];
2046   }
2047
2048   $main::lxdebug->leave_sub();
2049 }
2050
2051 sub _get_printers {
2052   $main::lxdebug->enter_sub();
2053
2054   my ($self, $dbh, $key) = @_;
2055
2056   $key = "all_printers" unless ($key);
2057
2058   my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2059
2060   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2061
2062   $main::lxdebug->leave_sub();
2063 }
2064
2065 sub _get_charts {
2066   $main::lxdebug->enter_sub();
2067
2068   my ($self, $dbh, $params) = @_;
2069   my ($key);
2070
2071   $key = $params->{key};
2072   $key = "all_charts" unless ($key);
2073
2074   my $transdate = quote_db_date($params->{transdate});
2075
2076   my $query =
2077     qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2078     qq|FROM chart c | .
2079     qq|LEFT JOIN taxkeys tk ON | .
2080     qq|(tk.id = (SELECT id FROM taxkeys | .
2081     qq|          WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2082     qq|          ORDER BY startdate DESC LIMIT 1)) | .
2083     qq|ORDER BY c.accno|;
2084
2085   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2086
2087   $main::lxdebug->leave_sub();
2088 }
2089
2090 sub _get_taxcharts {
2091   $main::lxdebug->enter_sub();
2092
2093   my ($self, $dbh, $params) = @_;
2094
2095   my $key = "all_taxcharts";
2096   my @where;
2097
2098   if (ref $params eq 'HASH') {
2099     $key = $params->{key} if ($params->{key});
2100     if ($params->{module} eq 'AR') {
2101       push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2102
2103     } elsif ($params->{module} eq 'AP') {
2104       push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2105     }
2106
2107   } elsif ($params) {
2108     $key = $params;
2109   }
2110
2111   my $where = @where ? ' WHERE ' . join(' AND ', map { "($_)" } @where) : '';
2112
2113   my $query = qq|SELECT * FROM tax $where ORDER BY taxkey, rate|;
2114
2115   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2116
2117   $main::lxdebug->leave_sub();
2118 }
2119
2120 sub _get_taxzones {
2121   $main::lxdebug->enter_sub();
2122
2123   my ($self, $dbh, $key) = @_;
2124
2125   $key = "all_taxzones" unless ($key);
2126
2127   my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2128
2129   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2130
2131   $main::lxdebug->leave_sub();
2132 }
2133
2134 sub _get_employees {
2135   $main::lxdebug->enter_sub();
2136
2137   my ($self, $dbh, $default_key, $key) = @_;
2138
2139   $key = $default_key unless ($key);
2140   $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2141
2142   $main::lxdebug->leave_sub();
2143 }
2144
2145 sub _get_business_types {
2146   $main::lxdebug->enter_sub();
2147
2148   my ($self, $dbh, $key) = @_;
2149
2150   my $options       = ref $key eq 'HASH' ? $key : { key => $key };
2151   $options->{key} ||= "all_business_types";
2152   my $where         = '';
2153
2154   if (exists $options->{salesman}) {
2155     $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2156   }
2157
2158   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2159
2160   $main::lxdebug->leave_sub();
2161 }
2162
2163 sub _get_languages {
2164   $main::lxdebug->enter_sub();
2165
2166   my ($self, $dbh, $key) = @_;
2167
2168   $key = "all_languages" unless ($key);
2169
2170   my $query = qq|SELECT * FROM language ORDER BY id|;
2171
2172   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2173
2174   $main::lxdebug->leave_sub();
2175 }
2176
2177 sub _get_dunning_configs {
2178   $main::lxdebug->enter_sub();
2179
2180   my ($self, $dbh, $key) = @_;
2181
2182   $key = "all_dunning_configs" unless ($key);
2183
2184   my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2185
2186   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2187
2188   $main::lxdebug->leave_sub();
2189 }
2190
2191 sub _get_currencies {
2192 $main::lxdebug->enter_sub();
2193
2194   my ($self, $dbh, $key) = @_;
2195
2196   $key = "all_currencies" unless ($key);
2197
2198   $self->{$key} = [$self->get_all_currencies()];
2199
2200   $main::lxdebug->leave_sub();
2201 }
2202
2203 sub _get_payments {
2204 $main::lxdebug->enter_sub();
2205
2206   my ($self, $dbh, $key) = @_;
2207
2208   $key = "all_payments" unless ($key);
2209
2210   my $query = qq|SELECT * FROM payment_terms ORDER BY sortkey|;
2211
2212   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2213
2214   $main::lxdebug->leave_sub();
2215 }
2216
2217 sub _get_customers {
2218   $main::lxdebug->enter_sub();
2219
2220   my ($self, $dbh, $key) = @_;
2221
2222   my $options        = ref $key eq 'HASH' ? $key : { key => $key };
2223   $options->{key}  ||= "all_customers";
2224   my $limit_clause   = $options->{limit} ? "LIMIT $options->{limit}" : '';
2225
2226   my @where;
2227   push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if  $options->{business_is_salesman};
2228   push @where, qq|NOT obsolete|                                            if !$options->{with_obsolete};
2229   my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2230
2231   my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2232   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2233
2234   $main::lxdebug->leave_sub();
2235 }
2236
2237 sub _get_vendors {
2238   $main::lxdebug->enter_sub();
2239
2240   my ($self, $dbh, $key) = @_;
2241
2242   $key = "all_vendors" unless ($key);
2243
2244   my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2245
2246   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2247
2248   $main::lxdebug->leave_sub();
2249 }
2250
2251 sub _get_departments {
2252   $main::lxdebug->enter_sub();
2253
2254   my ($self, $dbh, $key) = @_;
2255
2256   $key = "all_departments" unless ($key);
2257
2258   my $query = qq|SELECT * FROM department ORDER BY description|;
2259
2260   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2261
2262   $main::lxdebug->leave_sub();
2263 }
2264
2265 sub _get_warehouses {
2266   $main::lxdebug->enter_sub();
2267
2268   my ($self, $dbh, $param) = @_;
2269
2270   my ($key, $bins_key);
2271
2272   if ('' eq ref $param) {
2273     $key = $param;
2274
2275   } else {
2276     $key      = $param->{key};
2277     $bins_key = $param->{bins};
2278   }
2279
2280   my $query = qq|SELECT w.* FROM warehouse w
2281                  WHERE (NOT w.invalid) AND
2282                    ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2283                  ORDER BY w.sortkey|;
2284
2285   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2286
2287   if ($bins_key) {
2288     $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?
2289                 ORDER BY description|;
2290     my $sth = prepare_query($self, $dbh, $query);
2291
2292     foreach my $warehouse (@{ $self->{$key} }) {
2293       do_statement($self, $sth, $query, $warehouse->{id});
2294       $warehouse->{$bins_key} = [];
2295
2296       while (my $ref = $sth->fetchrow_hashref()) {
2297         push @{ $warehouse->{$bins_key} }, $ref;
2298       }
2299     }
2300     $sth->finish();
2301   }
2302
2303   $main::lxdebug->leave_sub();
2304 }
2305
2306 sub _get_simple {
2307   $main::lxdebug->enter_sub();
2308
2309   my ($self, $dbh, $table, $key, $sortkey) = @_;
2310
2311   my $query  = qq|SELECT * FROM $table|;
2312   $query    .= qq| ORDER BY $sortkey| if ($sortkey);
2313
2314   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2315
2316   $main::lxdebug->leave_sub();
2317 }
2318
2319 #sub _get_groups {
2320 #  $main::lxdebug->enter_sub();
2321 #
2322 #  my ($self, $dbh, $key) = @_;
2323 #
2324 #  $key ||= "all_groups";
2325 #
2326 #  my $groups = $main::auth->read_groups();
2327 #
2328 #  $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2329 #
2330 #  $main::lxdebug->leave_sub();
2331 #}
2332
2333 sub get_lists {
2334   $main::lxdebug->enter_sub();
2335
2336   my $self = shift;
2337   my %params = @_;
2338
2339   my $dbh = $self->get_standard_dbh(\%main::myconfig);
2340   my ($sth, $query, $ref);
2341
2342   my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2343   my $vc_id = $self->{"${vc}_id"};
2344
2345   if ($params{"contacts"}) {
2346     $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2347   }
2348
2349   if ($params{"shipto"}) {
2350     $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2351   }
2352
2353   if ($params{"projects"} || $params{"all_projects"}) {
2354     $self->_get_projects($dbh, $params{"all_projects"} ?
2355                          $params{"all_projects"} : $params{"projects"},
2356                          $params{"all_projects"} ? 1 : 0);
2357   }
2358
2359   if ($params{"printers"}) {
2360     $self->_get_printers($dbh, $params{"printers"});
2361   }
2362
2363   if ($params{"languages"}) {
2364     $self->_get_languages($dbh, $params{"languages"});
2365   }
2366
2367   if ($params{"charts"}) {
2368     $self->_get_charts($dbh, $params{"charts"});
2369   }
2370
2371   if ($params{"taxcharts"}) {
2372     $self->_get_taxcharts($dbh, $params{"taxcharts"});
2373   }
2374
2375   if ($params{"taxzones"}) {
2376     $self->_get_taxzones($dbh, $params{"taxzones"});
2377   }
2378
2379   if ($params{"employees"}) {
2380     $self->_get_employees($dbh, "all_employees", $params{"employees"});
2381   }
2382
2383   if ($params{"salesmen"}) {
2384     $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2385   }
2386
2387   if ($params{"business_types"}) {
2388     $self->_get_business_types($dbh, $params{"business_types"});
2389   }
2390
2391   if ($params{"dunning_configs"}) {
2392     $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2393   }
2394
2395   if($params{"currencies"}) {
2396     $self->_get_currencies($dbh, $params{"currencies"});
2397   }
2398
2399   if($params{"customers"}) {
2400     $self->_get_customers($dbh, $params{"customers"});
2401   }
2402
2403   if($params{"vendors"}) {
2404     if (ref $params{"vendors"} eq 'HASH') {
2405       $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2406     } else {
2407       $self->_get_vendors($dbh, $params{"vendors"});
2408     }
2409   }
2410
2411   if($params{"payments"}) {
2412     $self->_get_payments($dbh, $params{"payments"});
2413   }
2414
2415   if($params{"departments"}) {
2416     $self->_get_departments($dbh, $params{"departments"});
2417   }
2418
2419   if ($params{price_factors}) {
2420     $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2421   }
2422
2423   if ($params{warehouses}) {
2424     $self->_get_warehouses($dbh, $params{warehouses});
2425   }
2426
2427 #  if ($params{groups}) {
2428 #    $self->_get_groups($dbh, $params{groups});
2429 #  }
2430
2431   if ($params{partsgroup}) {
2432     $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2433   }
2434
2435   $main::lxdebug->leave_sub();
2436 }
2437
2438 # this sub gets the id and name from $table
2439 sub get_name {
2440   $main::lxdebug->enter_sub();
2441
2442   my ($self, $myconfig, $table) = @_;
2443
2444   # connect to database
2445   my $dbh = $self->get_standard_dbh($myconfig);
2446
2447   $table = $table eq "customer" ? "customer" : "vendor";
2448   my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2449
2450   my ($query, @values);
2451
2452   if (!$self->{openinvoices}) {
2453     my $where;
2454     if ($self->{customernumber} ne "") {
2455       $where = qq|(vc.customernumber ILIKE ?)|;
2456       push(@values, '%' . $self->{customernumber} . '%');
2457     } else {
2458       $where = qq|(vc.name ILIKE ?)|;
2459       push(@values, '%' . $self->{$table} . '%');
2460     }
2461
2462     $query =
2463       qq~SELECT vc.id, vc.name,
2464            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2465          FROM $table vc
2466          WHERE $where AND (NOT vc.obsolete)
2467          ORDER BY vc.name~;
2468   } else {
2469     $query =
2470       qq~SELECT DISTINCT vc.id, vc.name,
2471            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2472          FROM $arap a
2473          JOIN $table vc ON (a.${table}_id = vc.id)
2474          WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2475          ORDER BY vc.name~;
2476     push(@values, '%' . $self->{$table} . '%');
2477   }
2478
2479   $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2480
2481   $main::lxdebug->leave_sub();
2482
2483   return scalar(@{ $self->{name_list} });
2484 }
2485
2486 # the selection sub is used in the AR, AP, IS, IR, DO and OE module
2487 #
2488 sub all_vc {
2489   $main::lxdebug->enter_sub();
2490
2491   my ($self, $myconfig, $table, $module) = @_;
2492
2493   my $ref;
2494   my $dbh = $self->get_standard_dbh;
2495
2496   $table = $table eq "customer" ? "customer" : "vendor";
2497
2498   # build selection list
2499   # Hotfix für Bug 1837 - Besser wäre es alte Buchungsbelege
2500   # OHNE Auswahlliste (reines Textfeld) zu laden. Hilft aber auch
2501   # nicht für veränderbare Belege (oe, do, ...)
2502   my $obsolete = $self->{id} ? '' : "WHERE NOT obsolete";
2503   my $query = qq|SELECT count(*) FROM $table $obsolete|;
2504   my ($count) = selectrow_query($self, $dbh, $query);
2505
2506   if ($count <= $myconfig->{vclimit}) {
2507     $query = qq|SELECT id, name, salesman_id
2508                 FROM $table $obsolete
2509                 ORDER BY name|;
2510     $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2511   }
2512
2513   # get self
2514   $self->get_employee($dbh);
2515
2516   # setup sales contacts
2517   $query = qq|SELECT e.id, e.name
2518               FROM employee e
2519               WHERE (e.sales = '1') AND (NOT e.id = ?)
2520               ORDER BY name|;
2521   $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2522
2523   # this is for self
2524   push(@{ $self->{all_employees} },
2525        { id   => $self->{employee_id},
2526          name => $self->{employee} });
2527
2528     # prepare query for departments
2529     $query = qq|SELECT id, description
2530                 FROM department
2531                 ORDER BY description|;
2532
2533   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2534
2535   # get languages
2536   $query = qq|SELECT id, description
2537               FROM language
2538               ORDER BY id|;
2539
2540   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2541
2542   # get printer
2543   $query = qq|SELECT printer_description, id
2544               FROM printers
2545               ORDER BY printer_description|;
2546
2547   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2548
2549   # get payment terms
2550   $query = qq|SELECT id, description
2551               FROM payment_terms
2552               ORDER BY sortkey|;
2553
2554   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2555
2556   $main::lxdebug->leave_sub();
2557 }
2558
2559 sub language_payment {
2560   $main::lxdebug->enter_sub();
2561
2562   my ($self, $myconfig) = @_;
2563
2564   my $dbh = $self->get_standard_dbh($myconfig);
2565   # get languages
2566   my $query = qq|SELECT id, description
2567                  FROM language
2568                  ORDER BY id|;
2569
2570   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2571
2572   # get printer
2573   $query = qq|SELECT printer_description, id
2574               FROM printers
2575               ORDER BY printer_description|;
2576
2577   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2578
2579   # get payment terms
2580   $query = qq|SELECT id, description
2581               FROM payment_terms
2582               ORDER BY sortkey|;
2583
2584   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2585
2586   # get buchungsgruppen
2587   $query = qq|SELECT id, description
2588               FROM buchungsgruppen|;
2589
2590   $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2591
2592   $main::lxdebug->leave_sub();
2593 }
2594
2595 # this is only used for reports
2596 sub all_departments {
2597   $main::lxdebug->enter_sub();
2598
2599   my ($self, $myconfig, $table) = @_;
2600
2601   my $dbh = $self->get_standard_dbh($myconfig);
2602
2603   my $query = qq|SELECT id, description
2604                  FROM department
2605                  ORDER BY description|;
2606   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2607
2608   delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2609
2610   $main::lxdebug->leave_sub();
2611 }
2612
2613 sub create_links {
2614   $main::lxdebug->enter_sub();
2615
2616   my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2617
2618   my ($fld, $arap);
2619   if ($table eq "customer") {
2620     $fld = "buy";
2621     $arap = "ar";
2622   } else {
2623     $table = "vendor";
2624     $fld = "sell";
2625     $arap = "ap";
2626   }
2627
2628   $self->all_vc($myconfig, $table, $module);
2629
2630   # get last customers or vendors
2631   my ($query, $sth, $ref);
2632
2633   my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2634   my %xkeyref = ();
2635
2636   if (!$self->{id}) {
2637
2638     my $transdate = "current_date";
2639     if ($self->{transdate}) {
2640       $transdate = $dbh->quote($self->{transdate});
2641     }
2642
2643     # now get the account numbers
2644 #    $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2645 #                FROM chart c, taxkeys tk
2646 #                WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2647 #                  (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2648 #                ORDER BY c.accno|;
2649
2650 #  same query as above, but without expensive subquery for each row. about 80% faster
2651     $query = qq|
2652       SELECT c.accno, c.description, c.link, c.taxkey_id, tk2.tax_id
2653         FROM chart c
2654         -- find newest entries in taxkeys
2655         INNER JOIN (
2656           SELECT chart_id, MAX(startdate) AS startdate
2657           FROM taxkeys
2658           WHERE (startdate <= $transdate)
2659           GROUP BY chart_id
2660         ) tk ON (c.id = tk.chart_id)
2661         -- and load all of those entries
2662         INNER JOIN taxkeys tk2
2663            ON (tk.chart_id = tk2.chart_id AND tk.startdate = tk2.startdate)
2664        WHERE (c.link LIKE ?)
2665       ORDER BY c.accno|;
2666
2667     $sth = $dbh->prepare($query);
2668
2669     do_statement($self, $sth, $query, '%' . $module . '%');
2670
2671     $self->{accounts} = "";
2672     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2673
2674       foreach my $key (split(/:/, $ref->{link})) {
2675         if ($key =~ /\Q$module\E/) {
2676
2677           # cross reference for keys
2678           $xkeyref{ $ref->{accno} } = $key;
2679
2680           push @{ $self->{"${module}_links"}{$key} },
2681             { accno       => $ref->{accno},
2682               description => $ref->{description},
2683               taxkey      => $ref->{taxkey_id},
2684               tax_id      => $ref->{tax_id} };
2685
2686           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2687         }
2688       }
2689     }
2690   }
2691
2692   # get taxkeys and description
2693   $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2694   $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2695
2696   if (($module eq "AP") || ($module eq "AR")) {
2697     # get tax rates and description
2698     $query = qq|SELECT * FROM tax|;
2699     $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2700   }
2701
2702   my $extra_columns = '';
2703   $extra_columns   .= 'a.direct_debit, ' if ($module eq 'AR') || ($module eq 'AP');
2704
2705   if ($self->{id}) {
2706     $query =
2707       qq|SELECT
2708            a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2709            a.duedate, a.ordnumber, a.taxincluded, (SELECT cu.name FROM currencies cu WHERE cu.id=a.currency_id) AS currency, a.notes,
2710            a.intnotes, a.department_id, a.amount AS oldinvtotal,
2711            a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2712            a.globalproject_id, ${extra_columns}
2713            c.name AS $table,
2714            d.description AS department,
2715            e.name AS employee
2716          FROM $arap a
2717          JOIN $table c ON (a.${table}_id = c.id)
2718          LEFT JOIN employee e ON (e.id = a.employee_id)
2719          LEFT JOIN department d ON (d.id = a.department_id)
2720          WHERE a.id = ?|;
2721     $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2722
2723     foreach my $key (keys %$ref) {
2724       $self->{$key} = $ref->{$key};
2725     }
2726
2727     my $transdate = "current_date";
2728     if ($self->{transdate}) {
2729       $transdate = $dbh->quote($self->{transdate});
2730     }
2731
2732     # now get the account numbers
2733     $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2734                 FROM chart c
2735                 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2736                 WHERE c.link LIKE ?
2737                   AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2738                     OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2739                 ORDER BY c.accno|;
2740
2741     $sth = $dbh->prepare($query);
2742     do_statement($self, $sth, $query, "%$module%");
2743
2744     $self->{accounts} = "";
2745     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2746
2747       foreach my $key (split(/:/, $ref->{link})) {
2748         if ($key =~ /\Q$module\E/) {
2749
2750           # cross reference for keys
2751           $xkeyref{ $ref->{accno} } = $key;
2752
2753           push @{ $self->{"${module}_links"}{$key} },
2754             { accno       => $ref->{accno},
2755               description => $ref->{description},
2756               taxkey      => $ref->{taxkey_id},
2757               tax_id      => $ref->{tax_id} };
2758
2759           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2760         }
2761       }
2762     }
2763
2764
2765     # get amounts from individual entries
2766     $query =
2767       qq|SELECT
2768            c.accno, c.description,
2769            a.acc_trans_id, a.source, a.amount, a.memo, a.transdate, a.gldate, a.cleared, a.project_id, a.taxkey,
2770            p.projectnumber,
2771            t.rate, t.id
2772          FROM acc_trans a
2773          LEFT JOIN chart c ON (c.id = a.chart_id)
2774          LEFT JOIN project p ON (p.id = a.project_id)
2775          LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2776                                     WHERE (tk.taxkey_id=a.taxkey) AND
2777                                       ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2778                                         THEN tk.chart_id = a.chart_id
2779                                         ELSE 1 = 1
2780                                         END)
2781                                        OR (c.link='%tax%')) AND
2782                                       (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2783          WHERE a.trans_id = ?
2784          AND a.fx_transaction = '0'
2785          ORDER BY a.acc_trans_id, a.transdate|;
2786     $sth = $dbh->prepare($query);
2787     do_statement($self, $sth, $query, $self->{id});
2788
2789     # get exchangerate for currency
2790     $self->{exchangerate} =
2791       $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2792     my $index = 0;
2793
2794     # store amounts in {acc_trans}{$key} for multiple accounts
2795     while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2796       $ref->{exchangerate} =
2797         $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2798       if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2799         $index++;
2800       }
2801       if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2802         $ref->{amount} *= -1;
2803       }
2804       $ref->{index} = $index;
2805
2806       push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2807     }
2808
2809     $sth->finish;
2810     #check das:
2811     $query =
2812       qq|SELECT
2813            d.closedto, d.revtrans,
2814            (SELECT cu.name FROM currencies cu WHERE cu.id=d.currency_id) AS defaultcurrency,
2815            (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2816            (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2817          FROM defaults d|;
2818     $ref = selectfirst_hashref_query($self, $dbh, $query);
2819     map { $self->{$_} = $ref->{$_} } keys %$ref;
2820
2821   } else {
2822
2823     # get date
2824     $query =
2825        qq|SELECT
2826             current_date AS transdate, d.closedto, d.revtrans,
2827             (SELECT cu.name FROM currencies cu WHERE cu.id=d.currency_id) AS defaultcurrency,
2828             (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2829             (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2830           FROM defaults d|;
2831     $ref = selectfirst_hashref_query($self, $dbh, $query);
2832     map { $self->{$_} = $ref->{$_} } keys %$ref;
2833
2834     if ($self->{"$self->{vc}_id"}) {
2835
2836       # only setup currency
2837       ($self->{currency}) = $self->{defaultcurrency} if !$self->{currency};
2838
2839     } else {
2840
2841       $self->lastname_used($dbh, $myconfig, $table, $module);
2842
2843       # get exchangerate for currency
2844       $self->{exchangerate} =
2845         $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2846
2847     }
2848
2849   }
2850
2851   $main::lxdebug->leave_sub();
2852 }
2853
2854 sub lastname_used {
2855   $main::lxdebug->enter_sub();
2856
2857   my ($self, $dbh, $myconfig, $table, $module) = @_;
2858
2859   my ($arap, $where);
2860
2861   $table         = $table eq "customer" ? "customer" : "vendor";
2862   my %column_map = ("a.${table}_id"           => "${table}_id",
2863                     "a.department_id"         => "department_id",
2864                     "d.description"           => "department",
2865                     "ct.name"                 => $table,
2866                     "cu.name"                 => "currency",
2867                     "current_date + ct.terms" => "duedate",
2868     );
2869
2870   if ($self->{type} =~ /delivery_order/) {
2871     $arap  = 'delivery_orders';
2872     delete $column_map{"cu.currency"};
2873
2874   } elsif ($self->{type} =~ /_order/) {
2875     $arap  = 'oe';
2876     $where = "quotation = '0'";
2877
2878   } elsif ($self->{type} =~ /_quotation/) {
2879     $arap  = 'oe';
2880     $where = "quotation = '1'";
2881
2882   } elsif ($table eq 'customer') {
2883     $arap  = 'ar';
2884
2885   } else {
2886     $arap  = 'ap';
2887
2888   }
2889
2890   $where           = "($where) AND" if ($where);
2891   my $query        = qq|SELECT MAX(id) FROM $arap
2892                         WHERE $where ${table}_id > 0|;
2893   my ($trans_id)   = selectrow_query($self, $dbh, $query);
2894   $trans_id       *= 1;
2895
2896   my $column_spec  = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
2897   $query           = qq|SELECT $column_spec
2898                         FROM $arap a
2899                         LEFT JOIN $table     ct ON (a.${table}_id = ct.id)
2900                         LEFT JOIN department d  ON (a.department_id = d.id)
2901                         LEFT JOIN currencies cu ON (cu.id=ct.currency_id)
2902                         WHERE a.id = ?|;
2903   my $ref          = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
2904
2905   map { $self->{$_} = $ref->{$_} } values %column_map;
2906
2907   $main::lxdebug->leave_sub();
2908 }
2909
2910 sub current_date {
2911   $main::lxdebug->enter_sub();
2912
2913   my $self     = shift;
2914   my $myconfig = shift || \%::myconfig;
2915   my ($thisdate, $days) = @_;
2916
2917   my $dbh = $self->get_standard_dbh($myconfig);
2918   my $query;
2919
2920   $days *= 1;
2921   if ($thisdate) {
2922     my $dateformat = $myconfig->{dateformat};
2923     $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
2924     $thisdate = $dbh->quote($thisdate);
2925     $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
2926   } else {
2927     $query = qq|SELECT current_date AS thisdate|;
2928   }
2929
2930   ($thisdate) = selectrow_query($self, $dbh, $query);
2931
2932   $main::lxdebug->leave_sub();
2933
2934   return $thisdate;
2935 }
2936
2937 sub like {
2938   $main::lxdebug->enter_sub();
2939
2940   my ($self, $string) = @_;
2941
2942   if ($string !~ /%/) {
2943     $string = "%$string%";
2944   }
2945
2946   $string =~ s/\'/\'\'/g;
2947
2948   $main::lxdebug->leave_sub();
2949
2950   return $string;
2951 }
2952
2953 sub redo_rows {
2954   $main::lxdebug->enter_sub();
2955
2956   my ($self, $flds, $new, $count, $numrows) = @_;
2957
2958   my @ndx = ();
2959
2960   map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
2961
2962   my $i = 0;
2963
2964   # fill rows
2965   foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
2966     $i++;
2967     my $j = $item->{ndx} - 1;
2968     map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
2969   }
2970
2971   # delete empty rows
2972   for $i ($count + 1 .. $numrows) {
2973     map { delete $self->{"${_}_$i"} } @{$flds};
2974   }
2975
2976   $main::lxdebug->leave_sub();
2977 }
2978
2979 sub update_status {
2980   $main::lxdebug->enter_sub();
2981
2982   my ($self, $myconfig) = @_;
2983
2984   my ($i, $id);
2985
2986   my $dbh = $self->dbconnect_noauto($myconfig);
2987
2988   my $query = qq|DELETE FROM status
2989                  WHERE (formname = ?) AND (trans_id = ?)|;
2990   my $sth = prepare_query($self, $dbh, $query);
2991
2992   if ($self->{formname} =~ /(check|receipt)/) {
2993     for $i (1 .. $self->{rowcount}) {
2994       do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
2995     }
2996   } else {
2997     do_statement($self, $sth, $query, $self->{formname}, $self->{id});
2998   }
2999   $sth->finish();
3000
3001   my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3002   my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3003
3004   my %queued = split / /, $self->{queued};
3005   my @values;
3006
3007   if ($self->{formname} =~ /(check|receipt)/) {
3008
3009     # this is a check or receipt, add one entry for each lineitem
3010     my ($accno) = split /--/, $self->{account};
3011     $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3012                 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3013     @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3014     $sth = prepare_query($self, $dbh, $query);
3015
3016     for $i (1 .. $self->{rowcount}) {
3017       if ($self->{"checked_$i"}) {
3018         do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3019       }
3020     }
3021     $sth->finish();
3022
3023   } else {
3024     $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3025                 VALUES (?, ?, ?, ?, ?)|;
3026     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3027              $queued{$self->{formname}}, $self->{formname});
3028   }
3029
3030   $dbh->commit;
3031   $dbh->disconnect;
3032
3033   $main::lxdebug->leave_sub();
3034 }
3035
3036 sub save_status {
3037   $main::lxdebug->enter_sub();
3038
3039   my ($self, $dbh) = @_;
3040
3041   my ($query, $printed, $emailed);
3042
3043   my $formnames  = $self->{printed};
3044   my $emailforms = $self->{emailed};
3045
3046   $query = qq|DELETE FROM status
3047                  WHERE (formname = ?) AND (trans_id = ?)|;
3048   do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3049
3050   # this only applies to the forms
3051   # checks and receipts are posted when printed or queued
3052
3053   if ($self->{queued}) {
3054     my %queued = split / /, $self->{queued};
3055
3056     foreach my $formname (keys %queued) {
3057       $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3058       $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3059
3060       $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3061                   VALUES (?, ?, ?, ?, ?)|;
3062       do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3063
3064       $formnames  =~ s/\Q$self->{formname}\E//;
3065       $emailforms =~ s/\Q$self->{formname}\E//;
3066
3067     }
3068   }
3069
3070   # save printed, emailed info
3071   $formnames  =~ s/^ +//g;
3072   $emailforms =~ s/^ +//g;
3073
3074   my %status = ();
3075   map { $status{$_}{printed} = 1 } split / +/, $formnames;
3076   map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3077
3078   foreach my $formname (keys %status) {
3079     $printed = ($formnames  =~ /\Q$self->{formname}\E/) ? "1" : "0";
3080     $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3081
3082     $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3083                 VALUES (?, ?, ?, ?)|;
3084     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3085   }
3086
3087   $main::lxdebug->leave_sub();
3088 }
3089
3090 #--- 4 locale ---#
3091 # $main::locale->text('SAVED')
3092 # $main::locale->text('DELETED')
3093 # $main::locale->text('ADDED')
3094 # $main::locale->text('PAYMENT POSTED')
3095 # $main::locale->text('POSTED')
3096 # $main::locale->text('POSTED AS NEW')
3097 # $main::locale->text('ELSE')
3098 # $main::locale->text('SAVED FOR DUNNING')
3099 # $main::locale->text('DUNNING STARTED')
3100 # $main::locale->text('PRINTED')
3101 # $main::locale->text('MAILED')
3102 # $main::locale->text('SCREENED')
3103 # $main::locale->text('CANCELED')
3104 # $main::locale->text('invoice')
3105 # $main::locale->text('proforma')
3106 # $main::locale->text('sales_order')
3107 # $main::locale->text('pick_list')
3108 # $main::locale->text('purchase_order')
3109 # $main::locale->text('bin_list')
3110 # $main::locale->text('sales_quotation')
3111 # $main::locale->text('request_quotation')
3112
3113 sub save_history {
3114   $main::lxdebug->enter_sub();
3115
3116   my $self = shift;
3117   my $dbh  = shift || $self->get_standard_dbh;
3118
3119   if(!exists $self->{employee_id}) {
3120     &get_employee($self, $dbh);
3121   }
3122
3123   my $query =
3124    qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3125    qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3126   my @values = (conv_i($self->{id}), $self->{login},
3127                 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3128   do_query($self, $dbh, $query, @values);
3129
3130   $dbh->commit;
3131
3132   $main::lxdebug->leave_sub();
3133 }
3134
3135 sub get_history {
3136   $main::lxdebug->enter_sub();
3137
3138   my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3139   my ($orderBy, $desc) = split(/\-\-/, $order);
3140   $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3141   my @tempArray;
3142   my $i = 0;
3143   if ($trans_id ne "") {
3144     my $query =
3145       qq|SELECT h.employee_id, h.itime::timestamp(0) AS itime, h.addition, h.what_done, emp.name, h.snumbers, h.trans_id AS id | .
3146       qq|FROM history_erp h | .
3147       qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3148       qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3149       $order;
3150
3151     my $sth = $dbh->prepare($query) || $self->dberror($query);
3152
3153     $sth->execute() || $self->dberror("$query");
3154
3155     while(my $hash_ref = $sth->fetchrow_hashref()) {
3156       $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3157       $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3158       $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3159       $tempArray[$i++] = $hash_ref;
3160     }
3161     $main::lxdebug->leave_sub() and return \@tempArray
3162       if ($i > 0 && $tempArray[0] ne "");
3163   }
3164   $main::lxdebug->leave_sub();
3165   return 0;
3166 }
3167
3168 sub update_defaults {
3169   $main::lxdebug->enter_sub();
3170
3171   my ($self, $myconfig, $fld, $provided_dbh) = @_;
3172
3173   my $dbh;
3174   if ($provided_dbh) {
3175     $dbh = $provided_dbh;
3176   } else {
3177     $dbh = $self->dbconnect_noauto($myconfig);
3178   }
3179   my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3180   my $sth   = $dbh->prepare($query);
3181
3182   $sth->execute || $self->dberror($query);
3183   my ($var) = $sth->fetchrow_array;
3184   $sth->finish;
3185
3186   $var   = 0 if !defined($var) || ($var eq '');
3187   $var   = SL::PrefixedNumber->new(number => $var)->get_next;
3188   $query = qq|UPDATE defaults SET $fld = ?|;
3189   do_query($self, $dbh, $query, $var);
3190
3191   if (!$provided_dbh) {
3192     $dbh->commit;
3193     $dbh->disconnect;
3194   }
3195
3196   $main::lxdebug->leave_sub();
3197
3198   return $var;
3199 }
3200
3201 sub update_business {
3202   $main::lxdebug->enter_sub();
3203
3204   my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3205
3206   my $dbh;
3207   if ($provided_dbh) {
3208     $dbh = $provided_dbh;
3209   } else {
3210     $dbh = $self->dbconnect_noauto($myconfig);
3211   }
3212   my $query =
3213     qq|SELECT customernumberinit FROM business
3214        WHERE id = ? FOR UPDATE|;
3215   my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3216
3217   return undef unless $var;
3218
3219   if ($var =~ m/\d+$/) {
3220     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3221     my $len_diff = length($var) - $-[0] - length($new_var);
3222     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3223
3224   } else {
3225     $var = $var . '1';
3226   }
3227
3228   $query = qq|UPDATE business
3229               SET customernumberinit = ?
3230               WHERE id = ?|;
3231   do_query($self, $dbh, $query, $var, $business_id);
3232
3233   if (!$provided_dbh) {
3234     $dbh->commit;
3235     $dbh->disconnect;
3236   }
3237
3238   $main::lxdebug->leave_sub();
3239
3240   return $var;
3241 }
3242
3243 sub get_partsgroup {
3244   $main::lxdebug->enter_sub();
3245
3246   my ($self, $myconfig, $p) = @_;
3247   my $target = $p->{target} || 'all_partsgroup';
3248
3249   my $dbh = $self->get_standard_dbh($myconfig);
3250
3251   my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3252                  FROM partsgroup pg
3253                  JOIN parts p ON (p.partsgroup_id = pg.id) |;
3254   my @values;
3255
3256   if ($p->{searchitems} eq 'part') {
3257     $query .= qq|WHERE p.inventory_accno_id > 0|;
3258   }
3259   if ($p->{searchitems} eq 'service') {
3260     $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3261   }
3262   if ($p->{searchitems} eq 'assembly') {
3263     $query .= qq|WHERE p.assembly = '1'|;
3264   }
3265   if ($p->{searchitems} eq 'labor') {
3266     $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3267   }
3268
3269   $query .= qq|ORDER BY partsgroup|;
3270
3271   if ($p->{all}) {
3272     $query = qq|SELECT id, partsgroup FROM partsgroup
3273                 ORDER BY partsgroup|;
3274   }
3275
3276   if ($p->{language_code}) {
3277     $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3278                   t.description AS translation
3279                 FROM partsgroup pg
3280                 JOIN parts p ON (p.partsgroup_id = pg.id)
3281                 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3282                 ORDER BY translation|;
3283     @values = ($p->{language_code});
3284   }
3285
3286   $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3287
3288   $main::lxdebug->leave_sub();
3289 }
3290
3291 sub get_pricegroup {
3292   $main::lxdebug->enter_sub();
3293
3294   my ($self, $myconfig, $p) = @_;
3295
3296   my $dbh = $self->get_standard_dbh($myconfig);
3297
3298   my $query = qq|SELECT p.id, p.pricegroup
3299                  FROM pricegroup p|;
3300
3301   $query .= qq| ORDER BY pricegroup|;
3302
3303   if ($p->{all}) {
3304     $query = qq|SELECT id, pricegroup FROM pricegroup
3305                 ORDER BY pricegroup|;
3306   }
3307
3308   $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3309
3310   $main::lxdebug->leave_sub();
3311 }
3312
3313 sub all_years {
3314 # usage $form->all_years($myconfig, [$dbh])
3315 # return list of all years where bookings found
3316 # (@all_years)
3317
3318   $main::lxdebug->enter_sub();
3319
3320   my ($self, $myconfig, $dbh) = @_;
3321
3322   $dbh ||= $self->get_standard_dbh($myconfig);
3323
3324   # get years
3325   my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3326                    (SELECT MAX(transdate) FROM acc_trans)|;
3327   my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3328
3329   if ($myconfig->{dateformat} =~ /^yy/) {
3330     ($startdate) = split /\W/, $startdate;
3331     ($enddate) = split /\W/, $enddate;
3332   } else {
3333     (@_) = split /\W/, $startdate;
3334     $startdate = $_[2];
3335     (@_) = split /\W/, $enddate;
3336     $enddate = $_[2];
3337   }
3338
3339   my @all_years;
3340   $startdate = substr($startdate,0,4);
3341   $enddate = substr($enddate,0,4);
3342
3343   while ($enddate >= $startdate) {
3344     push @all_years, $enddate--;
3345   }
3346
3347   return @all_years;
3348
3349   $main::lxdebug->leave_sub();
3350 }
3351
3352 sub backup_vars {
3353   $main::lxdebug->enter_sub();
3354   my $self = shift;
3355   my @vars = @_;
3356
3357   map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3358
3359   $main::lxdebug->leave_sub();
3360 }
3361
3362 sub restore_vars {
3363   $main::lxdebug->enter_sub();
3364
3365   my $self = shift;
3366   my @vars = @_;
3367
3368   map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3369
3370   $main::lxdebug->leave_sub();
3371 }
3372
3373 sub prepare_for_printing {
3374   my ($self) = @_;
3375
3376   my $defaults         = SL::DB::Default->get;
3377
3378   $self->{templates} ||= $defaults->templates;
3379   $self->{formname}  ||= $self->{type};
3380   $self->{media}     ||= 'email';
3381
3382   die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3383
3384   # Several fields that used to reside in %::myconfig (stored in
3385   # auth.user_config) are now stored in defaults. Copy them over for
3386   # compatibility.
3387   $self->{$_} = $defaults->$_ for qw(company address taxnumber co_ustid duns sepa_creditor_id);
3388
3389   # set shipto from billto unless set
3390   my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3391   if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3392     $self->{shiptoname}   = $defaults->company;
3393     $self->{shiptostreet} = $defaults->address;
3394   }
3395
3396   my $language = $self->{language} ? '_' . $self->{language} : '';
3397
3398   my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3399   if ($self->{language_id}) {
3400     ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3401   } else {
3402     $output_dateformat   = $::myconfig{dateformat};
3403     $output_numberformat = $::myconfig{numberformat};
3404     $output_longdates    = 1;
3405   }
3406
3407   # Retrieve accounts for tax calculation.
3408   IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3409
3410   if ($self->{type} =~ /_delivery_order$/) {
3411     DO->order_details(\%::myconfig, $self);
3412   } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3413     OE->order_details(\%::myconfig, $self);
3414   } else {
3415     IS->invoice_details(\%::myconfig, $self, $::locale);
3416   }
3417
3418   # Chose extension & set source file name
3419   my $extension = 'html';
3420   if ($self->{format} eq 'postscript') {
3421     $self->{postscript}   = 1;
3422     $extension            = 'tex';
3423   } elsif ($self->{"format"} =~ /pdf/) {
3424     $self->{pdf}          = 1;
3425     $extension            = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3426   } elsif ($self->{"format"} =~ /opendocument/) {
3427     $self->{opendocument} = 1;
3428     $extension            = 'odt';
3429   } elsif ($self->{"format"} =~ /excel/) {
3430     $self->{excel}        = 1;
3431     $extension            = 'xls';
3432   }
3433
3434   my $printer_code    = $self->{printer_code} ? '_' . $self->{printer_code} : '';
3435   my $email_extension = -f ($defaults->templates . "/$self->{formname}_email${language}.${extension}") ? '_email' : '';
3436   $self->{IN}         = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3437
3438   # Format dates.
3439   $self->format_dates($output_dateformat, $output_longdates,
3440                       qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3441                          transdate_oe deliverydate_oe employee_startdate employee_enddate),
3442                       grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3443
3444   $self->reformat_numbers($output_numberformat, 2,
3445                           qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3446                           grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3447
3448   $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3449
3450   my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3451
3452   if (scalar @{ $cvar_date_fields }) {
3453     $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3454   }
3455
3456   while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3457     $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3458   }
3459
3460   return $self;
3461 }
3462
3463 sub format_dates {
3464   my ($self, $dateformat, $longformat, @indices) = @_;
3465
3466   $dateformat ||= $::myconfig{dateformat};
3467
3468   foreach my $idx (@indices) {
3469     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3470       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3471         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3472       }
3473     }
3474
3475     next unless defined $self->{$idx};
3476
3477     if (!ref($self->{$idx})) {
3478       $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3479
3480     } elsif (ref($self->{$idx}) eq "ARRAY") {
3481       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3482         $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3483       }
3484     }
3485   }
3486 }
3487
3488 sub reformat_numbers {
3489   my ($self, $numberformat, $places, @indices) = @_;
3490
3491   return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3492
3493   foreach my $idx (@indices) {
3494     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3495       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3496         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3497       }
3498     }
3499
3500     next unless defined $self->{$idx};
3501
3502     if (!ref($self->{$idx})) {
3503       $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3504
3505     } elsif (ref($self->{$idx}) eq "ARRAY") {
3506       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3507         $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3508       }
3509     }
3510   }
3511
3512   my $saved_numberformat    = $::myconfig{numberformat};
3513   $::myconfig{numberformat} = $numberformat;
3514
3515   foreach my $idx (@indices) {
3516     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3517       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3518         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3519       }
3520     }
3521
3522     next unless defined $self->{$idx};
3523
3524     if (!ref($self->{$idx})) {
3525       $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3526
3527     } elsif (ref($self->{$idx}) eq "ARRAY") {
3528       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3529         $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3530       }
3531     }
3532   }
3533
3534   $::myconfig{numberformat} = $saved_numberformat;
3535 }
3536
3537 sub layout {
3538   my ($self) = @_;
3539   $::lxdebug->enter_sub;
3540
3541   my %style_to_script_map = (
3542     v3  => 'v3',
3543     neu => 'new',
3544   );
3545
3546   my $menu_script = $style_to_script_map{$::myconfig{menustyle}} || '';
3547
3548   package main;
3549   require "bin/mozilla/menu$menu_script.pl";
3550   package Form;
3551   require SL::Controller::FrameHeader;
3552
3553
3554   my $layout = SL::Controller::FrameHeader->new->action_header . ::render();
3555
3556   $::lxdebug->leave_sub;
3557   return $layout;
3558 }
3559
3560 1;
3561
3562 __END__
3563
3564 =head1 NAME
3565
3566 SL::Form.pm - main data object.
3567
3568 =head1 SYNOPSIS
3569
3570 This is the main data object of kivitendo.
3571 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3572 Points of interest for a beginner are:
3573
3574  - $form->error            - renders a generic error in html. accepts an error message
3575  - $form->get_standard_dbh - returns a database connection for the
3576
3577 =head1 SPECIAL FUNCTIONS
3578
3579 =head2 C<update_business> PARAMS
3580
3581 PARAMS (not named):
3582  \%config,     - config hashref
3583  $business_id, - business id
3584  $dbh          - optional database handle
3585
3586 handles business (thats customer/vendor types) sequences.
3587
3588 special behaviour for empty strings in customerinitnumber field:
3589 will in this case not increase the value, and return undef.
3590
3591 =head2 C<redirect_header> $url
3592
3593 Generates a HTTP redirection header for the new C<$url>. Constructs an
3594 absolute URL including scheme, host name and port. If C<$url> is a
3595 relative URL then it is considered relative to kivitendo base URL.
3596
3597 This function C<die>s if headers have already been created with
3598 C<$::form-E<gt>header>.
3599
3600 Examples:
3601
3602   print $::form->redirect_header('oe.pl?action=edit&id=1234');
3603   print $::form->redirect_header('http://www.lx-office.org/');
3604
3605 =head2 C<header>
3606
3607 Generates a general purpose http/html header and includes most of the scripts
3608 and stylesheets needed. Stylesheets can be added with L<use_stylesheet>.
3609
3610 Only one header will be generated. If the method was already called in this
3611 request it will not output anything and return undef. Also if no
3612 HTTP_USER_AGENT is found, no header is generated.
3613
3614 Although header does not accept parameters itself, it will honor special
3615 hashkeys of its Form instance:
3616
3617 =over 4
3618
3619 =item refresh_time
3620
3621 =item refresh_url
3622
3623 If one of these is set, a http-equiv refresh is generated. Missing parameters
3624 default to 3 seconds and the refering url.
3625
3626 =item stylesheet
3627
3628 Either a scalar or an array ref. Will be inlined into the header. Add
3629 stylesheets with the L<use_stylesheet> function.
3630
3631 =item landscape
3632
3633 If true, a css snippet will be generated that sets the page in landscape mode.
3634
3635 =item favicon
3636
3637 Used to override the default favicon.
3638
3639 =item title
3640
3641 A html page title will be generated from this
3642
3643 =back
3644
3645 =cut