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