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