SL/Form.pm

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