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