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