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   $amount ||= 0;
 870   $dash   ||= '';
 871   my $neg = $amount < 0;
 872   my $force_places = defined $places && $places >= 0;
 873
 874   $amount = $self->round_amount($amount, abs $places) if $force_places;
 875   $amount = sprintf "%.*f", ($force_places ? $places : 10), abs $amount; # 6 is default for %fa
 876
 877   # before the sprintf amount was a number, afterwards it's a string. because of the dynamic nature of perl
 878   # this is easy to confuse, so keep in mind: before this comment no s///, m//, concat or other strong ops on
 879   # $amount. after this comment no +,-,*,/,abs. it will only introduce subtle bugs.
 880
 881   $amount =~ s/0*$// unless defined $places && $places == 0;             # cull trailing 0s
 882
 883   my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
 884   my @p = split(/\./, $amount);                                          # split amount at decimal point
 885
 886   $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1];                             # add 1,000 delimiters
 887   $amount = $p[0];
 888   if ($places || $p[1]) {
 889     $amount .= $d[0]
 890             .  ( $p[1] || '' )
 891             .  (0 x (abs($places || 0) - length ($p[1]||'')));           # pad the fraction
 892   }
 893
 894   $amount = do {
 895     ($dash =~ /-/)    ? ($neg ? "($amount)"                            : "$amount" )                              :
 896     ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
 897                         ($neg ? "-$amount"                             : "$amount" )                              ;
 898   };
 899
 900   $main::lxdebug->leave_sub(2);
 901   return $amount;
 902 }
 903
 904 sub format_amount_units {
 905   $main::lxdebug->enter_sub();
 906
 907   my $self             = shift;
 908   my %params           = @_;
 909
 910   my $myconfig         = \%main::myconfig;
 911   my $amount           = $params{amount} * 1;
 912   my $places           = $params{places};
 913   my $part_unit_name   = $params{part_unit};
 914   my $amount_unit_name = $params{amount_unit};
 915   my $conv_units       = $params{conv_units};
 916   my $max_places       = $params{max_places};
 917
 918   if (!$part_unit_name) {
 919     $main::lxdebug->leave_sub();
 920     return '';
 921   }
 922
 923   my $all_units        = AM->retrieve_all_units;
 924
 925   if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
 926     $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
 927   }
 928
 929   if (!scalar @{ $conv_units }) {
 930     my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
 931     $main::lxdebug->leave_sub();
 932     return $result;
 933   }
 934
 935   my $part_unit  = $all_units->{$part_unit_name};
 936   my $conv_unit  = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
 937
 938   $amount       *= $conv_unit->{factor};
 939
 940   my @values;
 941   my $num;
 942
 943   foreach my $unit (@$conv_units) {
 944     my $last = $unit->{name} eq $part_unit->{name};
 945     if (!$last) {
 946       $num     = int($amount / $unit->{factor});
 947       $amount -= $num * $unit->{factor};
 948     }
 949
 950     if ($last ? $amount : $num) {
 951       push @values, { "unit"   => $unit->{name},
 952                       "amount" => $last ? $amount / $unit->{factor} : $num,
 953                       "places" => $last ? $places : 0 };
 954     }
 955
 956     last if $last;
 957   }
 958
 959   if (!@values) {
 960     push @values, { "unit"   => $part_unit_name,
 961                     "amount" => 0,
 962                     "places" => 0 };
 963   }
 964
 965   my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
 966
 967   $main::lxdebug->leave_sub();
 968
 969   return $result;
 970 }
 971
 972 sub format_string {
 973   $main::lxdebug->enter_sub(2);
 974
 975   my $self  = shift;
 976   my $input = shift;
 977
 978   $input =~ s/(^|[^\#]) \#  (\d+)  /$1$_[$2 - 1]/gx;
 979   $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
 980   $input =~ s/\#\#/\#/g;
 981
 982   $main::lxdebug->leave_sub(2);
 983
 984   return $input;
 985 }
 986
 987 #
 988
 989 sub parse_amount {
 990   $main::lxdebug->enter_sub(2);
 991
 992   my ($self, $myconfig, $amount) = @_;
 993
 994   if (   ($myconfig->{numberformat} eq '1.000,00')
 995       || ($myconfig->{numberformat} eq '1000,00')) {
 996     $amount =~ s/\.//g;
 997     $amount =~ s/,/\./g;
 998   }
 999
1000   if ($myconfig->{numberformat} eq "1'000.00") {
1001     $amount =~ s/\'//g;
1002   }
1003
1004   $amount =~ s/,//g;
1005
1006   $main::lxdebug->leave_sub(2);
1007
1008   # Make sure no code wich is not a math expression ends up in eval().
1009   return 0 unless $amount =~ /^ [\s \d \( \) \- \+ \* \/ \. ]* $/x;
1010   return scalar(eval($amount)) * 1 ;
1011 }
1012
1013 sub round_amount {
1014   $main::lxdebug->enter_sub(2);
1015
1016   my ($self, $amount, $places) = @_;
1017   my $round_amount;
1018
1019   # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1020
1021   # Round amounts to eight places before rounding to the requested
1022   # number of places. This gets rid of errors due to internal floating
1023   # point representation.
1024   $amount       = $self->round_amount($amount, 8) if $places < 8;
1025   $amount       = $amount * (10**($places));
1026   $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1027
1028   $main::lxdebug->leave_sub(2);
1029
1030   return $round_amount;
1031
1032 }
1033
1034 sub parse_template {
1035   $main::lxdebug->enter_sub();
1036
1037   my ($self, $myconfig) = @_;
1038   my ($out, $out_mode);
1039
1040   local (*IN, *OUT);
1041
1042   my $userspath = $::lx_office_conf{paths}->{userspath};
1043
1044   $self->{"cwd"} = getcwd();
1045   $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1046
1047   my $ext_for_format;
1048
1049   my $template_type;
1050   if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1051     $template_type  = 'OpenDocument';
1052     $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1053
1054   } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1055     $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1056     $template_type    = 'LaTeX';
1057     $ext_for_format   = 'pdf';
1058
1059   } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1060     $template_type  = 'HTML';
1061     $ext_for_format = 'html';
1062
1063   } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1064     $template_type  = 'XML';
1065     $ext_for_format = 'xml';
1066
1067   } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1068     $template_type = 'XML';
1069
1070   } elsif ( $self->{"format"} =~ /excel/i ) {
1071     $template_type  = 'Excel';
1072     $ext_for_format = 'xls';
1073
1074   } elsif ( defined $self->{'format'}) {
1075     $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1076
1077   } elsif ( $self->{'format'} eq '' ) {
1078     $self->error("No Outputformat given: $self->{'format'}");
1079
1080   } else { #Catch the rest
1081     $self->error("Outputformat not defined: $self->{'format'}");
1082   }
1083
1084   my $template = SL::Template::create(type      => $template_type,
1085                                       file_name => $self->{IN},
1086                                       form      => $self,
1087                                       myconfig  => $myconfig,
1088                                       userspath => $userspath);
1089
1090   # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1091   $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1092
1093   if (!$self->{employee_id}) {
1094     map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1095   }
1096
1097   map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1098   map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1099
1100   $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1101
1102   # OUT is used for the media, screen, printer, email
1103   # for postscript we store a copy in a temporary file
1104   my ($temp_fh, $suffix);
1105   $suffix =  $self->{IN};
1106   $suffix =~ s/.*\.//;
1107   ($temp_fh, $self->{tmpfile}) = File::Temp::tempfile(
1108     'kivitendo-printXXXXXX',
1109     SUFFIX => '.' . ($suffix || 'tex'),
1110     DIR    => $userspath,
1111     UNLINK => ($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})? 0 : 1,
1112   );
1113   close $temp_fh;
1114
1115   if ($template->uses_temp_file() || $self->{media} eq 'email') {
1116     $out              = $self->{OUT};
1117     $out_mode         = $self->{OUT_MODE} || '>';
1118     $self->{OUT}      = "$self->{tmpfile}";
1119     $self->{OUT_MODE} = '>';
1120   }
1121
1122   my $result;
1123   my $command_formatter = sub {
1124     my ($out_mode, $out) = @_;
1125     return $out_mode eq '|-' ? SL::Template::create(type => 'ShellCommand', form => $self)->parse($out) : $out;
1126   };
1127
1128   if ($self->{OUT}) {
1129     $self->{OUT} = $command_formatter->($self->{OUT_MODE}, $self->{OUT});
1130     open(OUT, $self->{OUT_MODE}, $self->{OUT}) or $self->error("error on opening $self->{OUT} with mode $self->{OUT_MODE} : $!");
1131   } else {
1132     *OUT = ($::dispatcher->get_standard_filehandles)[1];
1133     $self->header;
1134   }
1135
1136   if (!$template->parse(*OUT)) {
1137     $self->cleanup();
1138     $self->error("$self->{IN} : " . $template->get_error());
1139   }
1140
1141   close OUT if $self->{OUT};
1142
1143   if ($self->{media} eq 'file') {
1144     copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1145     $self->cleanup;
1146     chdir("$self->{cwd}");
1147
1148     $::lxdebug->leave_sub();
1149
1150     return;
1151   }
1152
1153   if ($template->uses_temp_file() || $self->{media} eq 'email') {
1154
1155     if ($self->{media} eq 'email') {
1156
1157       my $mail = new Mailer;
1158
1159       map { $mail->{$_} = $self->{$_} }
1160         qw(cc bcc subject message version format);
1161       $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1162       $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1163       $mail->{from}   = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1164       $mail->{fileid} = time() . '.' . $$ . '.';
1165       $myconfig->{signature} =~ s/\r//g;
1166
1167       # if we send html or plain text inline
1168       if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1169         $mail->{contenttype}    =  "text/html";
1170         $mail->{message}        =~ s/\r//g;
1171         $mail->{message}        =~ s/\n/<br>\n/g;
1172         $myconfig->{signature}  =~ s/\n/<br>\n/g;
1173         $mail->{message}       .=  "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1174
1175         open(IN, "<", $self->{tmpfile})
1176           or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1177         $mail->{message} .= $_ while <IN>;
1178         close(IN);
1179
1180       } else {
1181
1182         if (!$self->{"do_not_attach"}) {
1183           my $attachment_name  =  $self->{attachment_filename} || $self->{tmpfile};
1184           $attachment_name     =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1185           $mail->{attachments} =  [{ "filename" => $self->{tmpfile},
1186                                      "name"     => $attachment_name }];
1187         }
1188
1189         $mail->{message}  =~ s/\r//g;
1190         $mail->{message} .=  "\n-- \n$myconfig->{signature}";
1191
1192       }
1193
1194       my $err = $mail->send();
1195       $self->error($self->cleanup . "$err") if ($err);
1196
1197     } else {
1198
1199       $self->{OUT}      = $out;
1200       $self->{OUT_MODE} = $out_mode;
1201
1202       my $numbytes = (-s $self->{tmpfile});
1203       open(IN, "<", $self->{tmpfile})
1204         or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1205       binmode IN;
1206
1207       $self->{copies} = 1 unless $self->{media} eq 'printer';
1208
1209       chdir("$self->{cwd}");
1210       #print(STDERR "Kopien $self->{copies}\n");
1211       #print(STDERR "OUT $self->{OUT}\n");
1212       for my $i (1 .. $self->{copies}) {
1213         if ($self->{OUT}) {
1214           $self->{OUT} = $command_formatter->($self->{OUT_MODE}, $self->{OUT});
1215
1216           open  OUT, $self->{OUT_MODE}, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1217           print OUT $_ while <IN>;
1218           close OUT;
1219           seek  IN, 0, 0;
1220
1221         } else {
1222           $self->{attachment_filename} = ($self->{attachment_filename})
1223                                        ? $self->{attachment_filename}
1224                                        : $self->generate_attachment_filename();
1225
1226           # launch application
1227           print qq|Content-Type: | . $template->get_mime_type() . qq|
1228 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1229 Content-Length: $numbytes
1230
1231 |;
1232
1233           $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1234         }
1235       }
1236
1237       close(IN);
1238     }
1239
1240   }
1241
1242   $self->cleanup;
1243
1244   chdir("$self->{cwd}");
1245   $main::lxdebug->leave_sub();
1246 }
1247
1248 sub get_formname_translation {
1249   $main::lxdebug->enter_sub();
1250   my ($self, $formname) = @_;
1251
1252   $formname ||= $self->{formname};
1253
1254   $self->{recipient_locale} ||=  Locale->lang_to_locale($self->{language});
1255   local $::locale = Locale->new($self->{recipient_locale});
1256
1257   my %formname_translations = (
1258     bin_list                => $main::locale->text('Bin List'),
1259     credit_note             => $main::locale->text('Credit Note'),
1260     invoice                 => $main::locale->text('Invoice'),
1261     pick_list               => $main::locale->text('Pick List'),
1262     proforma                => $main::locale->text('Proforma Invoice'),
1263     purchase_order          => $main::locale->text('Purchase Order'),
1264     request_quotation       => $main::locale->text('RFQ'),
1265     sales_order             => $main::locale->text('Confirmation'),
1266     sales_quotation         => $main::locale->text('Quotation'),
1267     storno_invoice          => $main::locale->text('Storno Invoice'),
1268     sales_delivery_order    => $main::locale->text('Delivery Order'),
1269     purchase_delivery_order => $main::locale->text('Delivery Order'),
1270     dunning                 => $main::locale->text('Dunning'),
1271   );
1272
1273   $main::lxdebug->leave_sub();
1274   return $formname_translations{$formname};
1275 }
1276
1277 sub get_number_prefix_for_type {
1278   $main::lxdebug->enter_sub();
1279   my ($self) = @_;
1280
1281   my $prefix =
1282       (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1283     : ($self->{type} =~ /_quotation$/)                        ? 'quo'
1284     : ($self->{type} =~ /_delivery_order$/)                   ? 'do'
1285     :                                                           'ord';
1286
1287   $main::lxdebug->leave_sub();
1288   return $prefix;
1289 }
1290
1291 sub get_extension_for_format {
1292   $main::lxdebug->enter_sub();
1293   my ($self)    = @_;
1294
1295   my $extension = $self->{format} =~ /pdf/i          ? ".pdf"
1296                 : $self->{format} =~ /postscript/i   ? ".ps"
1297                 : $self->{format} =~ /opendocument/i ? ".odt"
1298                 : $self->{format} =~ /excel/i        ? ".xls"
1299                 : $self->{format} =~ /html/i         ? ".html"
1300                 :                                      "";
1301
1302   $main::lxdebug->leave_sub();
1303   return $extension;
1304 }
1305
1306 sub generate_attachment_filename {
1307   $main::lxdebug->enter_sub();
1308   my ($self) = @_;
1309
1310   $self->{recipient_locale} ||=  Locale->lang_to_locale($self->{language});
1311   my $recipient_locale = Locale->new($self->{recipient_locale});
1312
1313   my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1314   my $prefix              = $self->get_number_prefix_for_type();
1315
1316   if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1317     $attachment_filename .= ' (' . $recipient_locale->text('Preview') . ')' . $self->get_extension_for_format();
1318
1319   } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1320     $attachment_filename .=  "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1321
1322   } else {
1323     $attachment_filename = "";
1324   }
1325
1326   $attachment_filename =  $main::locale->quote_special_chars('filenames', $attachment_filename);
1327   $attachment_filename =~ s|[\s/\\]+|_|g;
1328
1329   $main::lxdebug->leave_sub();
1330   return $attachment_filename;
1331 }
1332
1333 sub generate_email_subject {
1334   $main::lxdebug->enter_sub();
1335   my ($self) = @_;
1336
1337   my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1338   my $prefix  = $self->get_number_prefix_for_type();
1339
1340   if ($subject && $self->{"${prefix}number"}) {
1341     $subject .= " " . $self->{"${prefix}number"}
1342   }
1343
1344   $main::lxdebug->leave_sub();
1345   return $subject;
1346 }
1347
1348 sub cleanup {
1349   $main::lxdebug->enter_sub();
1350
1351   my ($self, $application) = @_;
1352
1353   my $error_code = $?;
1354
1355   chdir("$self->{tmpdir}");
1356
1357   my @err = ();
1358   if ((-1 == $error_code) || (127 == (($error_code) >> 8))) {
1359     push @err, $::locale->text('The application "#1" was not found on the system.', $application || 'pdflatex') . ' ' . $::locale->text('Please contact your administrator.');
1360
1361   } elsif (-f "$self->{tmpfile}.err") {
1362     open(FH, "$self->{tmpfile}.err");
1363     @err = <FH>;
1364     close(FH);
1365   }
1366
1367   if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1368     $self->{tmpfile} =~ s|.*/||g;
1369     # strip extension
1370     $self->{tmpfile} =~ s/\.\w+$//g;
1371     my $tmpfile = $self->{tmpfile};
1372     unlink(<$tmpfile.*>);
1373   }
1374
1375   chdir("$self->{cwd}");
1376
1377   $main::lxdebug->leave_sub();
1378
1379   return "@err";
1380 }
1381
1382 sub datetonum {
1383   $main::lxdebug->enter_sub();
1384
1385   my ($self, $date, $myconfig) = @_;
1386   my ($yy, $mm, $dd);
1387
1388   if ($date && $date =~ /\D/) {
1389
1390     if ($myconfig->{dateformat} =~ /^yy/) {
1391       ($yy, $mm, $dd) = split /\D/, $date;
1392     }
1393     if ($myconfig->{dateformat} =~ /^mm/) {
1394       ($mm, $dd, $yy) = split /\D/, $date;
1395     }
1396     if ($myconfig->{dateformat} =~ /^dd/) {
1397       ($dd, $mm, $yy) = split /\D/, $date;
1398     }
1399
1400     $dd *= 1;
1401     $mm *= 1;
1402     $yy = ($yy < 70) ? $yy + 2000 : $yy;
1403     $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1404
1405     $dd = "0$dd" if ($dd < 10);
1406     $mm = "0$mm" if ($mm < 10);
1407
1408     $date = "$yy$mm$dd";
1409   }
1410
1411   $main::lxdebug->leave_sub();
1412
1413   return $date;
1414 }
1415
1416 # Database routines used throughout
1417
1418 sub _dbconnect_options {
1419   my $self    = shift;
1420   my $options = { pg_enable_utf8 => $::locale->is_utf8,
1421                   @_ };
1422
1423   return $options;
1424 }
1425
1426 sub dbconnect {
1427   $main::lxdebug->enter_sub(2);
1428
1429   my ($self, $myconfig) = @_;
1430
1431   # connect to database
1432   my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1433     or $self->dberror;
1434
1435   # set db options
1436   if ($myconfig->{dboptions}) {
1437     $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1438   }
1439
1440   $main::lxdebug->leave_sub(2);
1441
1442   return $dbh;
1443 }
1444
1445 sub dbconnect_noauto {
1446   $main::lxdebug->enter_sub();
1447
1448   my ($self, $myconfig) = @_;
1449
1450   # connect to database
1451   my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1452     or $self->dberror;
1453
1454   # set db options
1455   if ($myconfig->{dboptions}) {
1456     $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1457   }
1458
1459   $main::lxdebug->leave_sub();
1460
1461   return $dbh;
1462 }
1463
1464 sub get_standard_dbh {
1465   $main::lxdebug->enter_sub(2);
1466
1467   my $self     = shift;
1468   my $myconfig = shift || \%::myconfig;
1469
1470   if ($standard_dbh && !$standard_dbh->{Active}) {
1471     $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1472     undef $standard_dbh;
1473   }
1474
1475   $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1476
1477   $main::lxdebug->leave_sub(2);
1478
1479   return $standard_dbh;
1480 }
1481
1482 sub date_closed {
1483   $main::lxdebug->enter_sub();
1484
1485   my ($self, $date, $myconfig) = @_;
1486   my $dbh = $self->dbconnect($myconfig);
1487
1488   my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1489   my $sth = prepare_execute_query($self, $dbh, $query, conv_date($date));
1490
1491   # Falls $date = '' - Fehlermeldung aus der Datenbank. Ich denke,
1492   # es ist sicher ein conv_date vorher IMMER auszuführen.
1493   # Testfälle ohne definiertes closedto:
1494   #   Leere Datumseingabe i.O.
1495   #     SELECT 1 FROM defaults WHERE '' < closedto
1496   #   normale Zahlungsbuchung über Rechnungsmaske i.O.
1497   #     SELECT 1 FROM defaults WHERE '10.05.2011' < closedto
1498   # Testfälle mit definiertem closedto (30.04.2011):
1499   #  Leere Datumseingabe i.O.
1500   #   SELECT 1 FROM defaults WHERE '' < closedto
1501   # normale Buchung im geschloßenem Zeitraum i.O.
1502   #   SELECT 1 FROM defaults WHERE '21.04.2011' < closedto
1503   #     Fehlermeldung: Es können keine Zahlungen für abgeschlossene Bücher gebucht werden!
1504   # normale Buchung in aktiver Buchungsperiode i.O.
1505   #   SELECT 1 FROM defaults WHERE '01.05.2011' < closedto
1506
1507   my ($closed) = $sth->fetchrow_array;
1508
1509   $main::lxdebug->leave_sub();
1510
1511   return $closed;
1512 }
1513
1514 sub update_balance {
1515   $main::lxdebug->enter_sub();
1516
1517   my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1518
1519   # if we have a value, go do it
1520   if ($value != 0) {
1521
1522     # retrieve balance from table
1523     my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1524     my $sth = prepare_execute_query($self, $dbh, $query, @values);
1525     my ($balance) = $sth->fetchrow_array;
1526     $sth->finish;
1527
1528     $balance += $value;
1529
1530     # update balance
1531     $query = "UPDATE $table SET $field = $balance WHERE $where";
1532     do_query($self, $dbh, $query, @values);
1533   }
1534   $main::lxdebug->leave_sub();
1535 }
1536
1537 sub update_exchangerate {
1538   $main::lxdebug->enter_sub();
1539
1540   my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1541   my ($query);
1542   # some sanity check for currency
1543   if ($curr eq '') {
1544     $main::lxdebug->leave_sub();
1545     return;
1546   }
1547   $query = qq|SELECT curr FROM defaults|;
1548
1549   my ($currency) = selectrow_query($self, $dbh, $query);
1550   my ($defaultcurrency) = split m/:/, $currency;
1551
1552
1553   if ($curr eq $defaultcurrency) {
1554     $main::lxdebug->leave_sub();
1555     return;
1556   }
1557
1558   $query = qq|SELECT e.curr FROM exchangerate e
1559                  WHERE e.curr = ? AND e.transdate = ?
1560                  FOR UPDATE|;
1561   my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1562
1563   if ($buy == 0) {
1564     $buy = "";
1565   }
1566   if ($sell == 0) {
1567     $sell = "";
1568   }
1569
1570   $buy = conv_i($buy, "NULL");
1571   $sell = conv_i($sell, "NULL");
1572
1573   my $set;
1574   if ($buy != 0 && $sell != 0) {
1575     $set = "buy = $buy, sell = $sell";
1576   } elsif ($buy != 0) {
1577     $set = "buy = $buy";
1578   } elsif ($sell != 0) {
1579     $set = "sell = $sell";
1580   }
1581
1582   if ($sth->fetchrow_array) {
1583     $query = qq|UPDATE exchangerate
1584                 SET $set
1585                 WHERE curr = ?
1586                 AND transdate = ?|;
1587
1588   } else {
1589     $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1590                 VALUES (?, $buy, $sell, ?)|;
1591   }
1592   $sth->finish;
1593   do_query($self, $dbh, $query, $curr, $transdate);
1594
1595   $main::lxdebug->leave_sub();
1596 }
1597
1598 sub save_exchangerate {
1599   $main::lxdebug->enter_sub();
1600
1601   my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1602
1603   my $dbh = $self->dbconnect($myconfig);
1604
1605   my ($buy, $sell);
1606
1607   $buy  = $rate if $fld eq 'buy';
1608   $sell = $rate if $fld eq 'sell';
1609
1610
1611   $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1612
1613
1614   $dbh->disconnect;
1615
1616   $main::lxdebug->leave_sub();
1617 }
1618
1619 sub get_exchangerate {
1620   $main::lxdebug->enter_sub();
1621
1622   my ($self, $dbh, $curr, $transdate, $fld) = @_;
1623   my ($query);
1624
1625   unless ($transdate) {
1626     $main::lxdebug->leave_sub();
1627     return 1;
1628   }
1629
1630   $query = qq|SELECT curr FROM defaults|;
1631
1632   my ($currency) = selectrow_query($self, $dbh, $query);
1633   my ($defaultcurrency) = split m/:/, $currency;
1634
1635   if ($currency eq $defaultcurrency) {
1636     $main::lxdebug->leave_sub();
1637     return 1;
1638   }
1639
1640   $query = qq|SELECT e.$fld FROM exchangerate e
1641                  WHERE e.curr = ? AND e.transdate = ?|;
1642   my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1643
1644
1645
1646   $main::lxdebug->leave_sub();
1647
1648   return $exchangerate;
1649 }
1650
1651 sub check_exchangerate {
1652   $main::lxdebug->enter_sub();
1653
1654   my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1655
1656   if ($fld !~/^buy|sell$/) {
1657     $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1658   }
1659
1660   unless ($transdate) {
1661     $main::lxdebug->leave_sub();
1662     return "";
1663   }
1664
1665   my ($defaultcurrency) = $self->get_default_currency($myconfig);
1666
1667   if ($currency eq $defaultcurrency) {
1668     $main::lxdebug->leave_sub();
1669     return 1;
1670   }
1671
1672   my $dbh   = $self->get_standard_dbh($myconfig);
1673   my $query = qq|SELECT e.$fld FROM exchangerate e
1674                  WHERE e.curr = ? AND e.transdate = ?|;
1675
1676   my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1677
1678   $main::lxdebug->leave_sub();
1679
1680   return $exchangerate;
1681 }
1682
1683 sub get_all_currencies {
1684   $main::lxdebug->enter_sub();
1685
1686   my $self     = shift;
1687   my $myconfig = shift || \%::myconfig;
1688   my $dbh      = $self->get_standard_dbh($myconfig);
1689
1690   my $query = qq|SELECT curr FROM defaults|;
1691
1692   my ($curr)     = selectrow_query($self, $dbh, $query);
1693   my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1694
1695   $main::lxdebug->leave_sub();
1696
1697   return @currencies;
1698 }
1699
1700 sub get_default_currency {
1701   $main::lxdebug->enter_sub();
1702
1703   my ($self, $myconfig) = @_;
1704   my @currencies        = $self->get_all_currencies($myconfig);
1705
1706   $main::lxdebug->leave_sub();
1707
1708   return $currencies[0];
1709 }
1710
1711 sub set_payment_options {
1712   $main::lxdebug->enter_sub();
1713
1714   my ($self, $myconfig, $transdate) = @_;
1715
1716   return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1717
1718   my $dbh = $self->get_standard_dbh($myconfig);
1719
1720   my $query =
1721     qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long , p.description | .
1722     qq|FROM payment_terms p | .
1723     qq|WHERE p.id = ?|;
1724
1725   ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1726    $self->{payment_terms}, $self->{payment_description}) =
1727      selectrow_query($self, $dbh, $query, $self->{payment_id});
1728
1729   if ($transdate eq "") {
1730     if ($self->{invdate}) {
1731       $transdate = $self->{invdate};
1732     } else {
1733       $transdate = $self->{transdate};
1734     }
1735   }
1736
1737   $query =
1738     qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1739     qq|FROM payment_terms|;
1740   ($self->{netto_date}, $self->{skonto_date}) =
1741     selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1742
1743   my ($invtotal, $total);
1744   my (%amounts, %formatted_amounts);
1745
1746   if ($self->{type} =~ /_order$/) {
1747     $amounts{invtotal} = $self->{ordtotal};
1748     $amounts{total}    = $self->{ordtotal};
1749
1750   } elsif ($self->{type} =~ /_quotation$/) {
1751     $amounts{invtotal} = $self->{quototal};
1752     $amounts{total}    = $self->{quototal};
1753
1754   } else {
1755     $amounts{invtotal} = $self->{invtotal};
1756     $amounts{total}    = $self->{total};
1757   }
1758   $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1759
1760   map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1761
1762   $amounts{skonto_amount}      = $amounts{invtotal} * $self->{percent_skonto};
1763   $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1764   $amounts{total_wo_skonto}    = $amounts{total}    * (1 - $self->{percent_skonto});
1765
1766   foreach (keys %amounts) {
1767     $amounts{$_}           = $self->round_amount($amounts{$_}, 2);
1768     $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1769   }
1770
1771   if ($self->{"language_id"}) {
1772     $query =
1773       qq|SELECT t.translation, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1774       qq|FROM generic_translations t | .
1775       qq|LEFT JOIN language l ON t.language_id = l.id | .
1776       qq|WHERE (t.language_id = ?)
1777            AND (t.translation_id = ?)
1778            AND (t.translation_type = 'SL::DB::PaymentTerm/description_long')|;
1779     my ($description_long, $output_numberformat, $output_dateformat,
1780       $output_longdates) =
1781       selectrow_query($self, $dbh, $query,
1782                       $self->{"language_id"}, $self->{"payment_id"});
1783
1784     $self->{payment_terms} = $description_long if ($description_long);
1785
1786     if ($output_dateformat) {
1787       foreach my $key (qw(netto_date skonto_date)) {
1788         $self->{$key} =
1789           $main::locale->reformat_date($myconfig, $self->{$key},
1790                                        $output_dateformat,
1791                                        $output_longdates);
1792       }
1793     }
1794
1795     if ($output_numberformat &&
1796         ($output_numberformat ne $myconfig->{"numberformat"})) {
1797       my $saved_numberformat = $myconfig->{"numberformat"};
1798       $myconfig->{"numberformat"} = $output_numberformat;
1799       map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1800       $myconfig->{"numberformat"} = $saved_numberformat;
1801     }
1802   }
1803
1804   $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1805   $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1806   $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1807   $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1808   $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1809   $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1810   $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1811
1812   map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1813
1814   $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1815
1816   $main::lxdebug->leave_sub();
1817
1818 }
1819
1820 sub get_template_language {
1821   $main::lxdebug->enter_sub();
1822
1823   my ($self, $myconfig) = @_;
1824
1825   my $template_code = "";
1826
1827   if ($self->{language_id}) {
1828     my $dbh = $self->get_standard_dbh($myconfig);
1829     my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1830     ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1831   }
1832
1833   $main::lxdebug->leave_sub();
1834
1835   return $template_code;
1836 }
1837
1838 sub get_printer_code {
1839   $main::lxdebug->enter_sub();
1840
1841   my ($self, $myconfig) = @_;
1842
1843   my $template_code = "";
1844
1845   if ($self->{printer_id}) {
1846     my $dbh = $self->get_standard_dbh($myconfig);
1847     my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1848     ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1849   }
1850
1851   $main::lxdebug->leave_sub();
1852
1853   return $template_code;
1854 }
1855
1856 sub get_shipto {
1857   $main::lxdebug->enter_sub();
1858
1859   my ($self, $myconfig) = @_;
1860
1861   my $template_code = "";
1862
1863   if ($self->{shipto_id}) {
1864     my $dbh = $self->get_standard_dbh($myconfig);
1865     my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1866     my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1867     map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1868   }
1869
1870   $main::lxdebug->leave_sub();
1871 }
1872
1873 sub add_shipto {
1874   $main::lxdebug->enter_sub();
1875
1876   my ($self, $dbh, $id, $module) = @_;
1877
1878   my $shipto;
1879   my @values;
1880
1881   foreach my $item (qw(name department_1 department_2 street zipcode city country
1882                        contact cp_gender phone fax email)) {
1883     if ($self->{"shipto$item"}) {
1884       $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1885     }
1886     push(@values, $self->{"shipto${item}"});
1887   }
1888
1889   if ($shipto) {
1890     if ($self->{shipto_id}) {
1891       my $query = qq|UPDATE shipto set
1892                        shiptoname = ?,
1893                        shiptodepartment_1 = ?,
1894                        shiptodepartment_2 = ?,
1895                        shiptostreet = ?,
1896                        shiptozipcode = ?,
1897                        shiptocity = ?,
1898                        shiptocountry = ?,
1899                        shiptocontact = ?,
1900                        shiptocp_gender = ?,
1901                        shiptophone = ?,
1902                        shiptofax = ?,
1903                        shiptoemail = ?
1904                      WHERE shipto_id = ?|;
1905       do_query($self, $dbh, $query, @values, $self->{shipto_id});
1906     } else {
1907       my $query = qq|SELECT * FROM shipto
1908                      WHERE shiptoname = ? AND
1909                        shiptodepartment_1 = ? AND
1910                        shiptodepartment_2 = ? AND
1911                        shiptostreet = ? AND
1912                        shiptozipcode = ? AND
1913                        shiptocity = ? AND
1914                        shiptocountry = ? AND
1915                        shiptocontact = ? AND
1916                        shiptocp_gender = ? AND
1917                        shiptophone = ? AND
1918                        shiptofax = ? AND
1919                        shiptoemail = ? AND
1920                        module = ? AND
1921                        trans_id = ?|;
1922       my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
1923       if(!$insert_check){
1924         $query =
1925           qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
1926                                  shiptostreet, shiptozipcode, shiptocity, shiptocountry,
1927                                  shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
1928              VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
1929         do_query($self, $dbh, $query, $id, @values, $module);
1930       }
1931     }
1932   }
1933
1934   $main::lxdebug->leave_sub();
1935 }
1936
1937 sub get_employee {
1938   $main::lxdebug->enter_sub();
1939
1940   my ($self, $dbh) = @_;
1941
1942   $dbh ||= $self->get_standard_dbh(\%main::myconfig);
1943
1944   my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
1945   ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
1946   $self->{"employee_id"} *= 1;
1947
1948   $main::lxdebug->leave_sub();
1949 }
1950
1951 sub get_employee_data {
1952   $main::lxdebug->enter_sub();
1953
1954   my $self     = shift;
1955   my %params   = @_;
1956
1957   Common::check_params(\%params, qw(prefix));
1958   Common::check_params_x(\%params, qw(id));
1959
1960   if (!$params{id}) {
1961     $main::lxdebug->leave_sub();
1962     return;
1963   }
1964
1965   my $myconfig = \%main::myconfig;
1966   my $dbh      = $params{dbh} || $self->get_standard_dbh($myconfig);
1967
1968   my ($login)  = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
1969
1970   if ($login) {
1971     my $user = User->new(login => $login);
1972     map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
1973
1974     $self->{$params{prefix} . '_login'}   = $login;
1975     $self->{$params{prefix} . '_name'}  ||= $login;
1976   }
1977
1978   $main::lxdebug->leave_sub();
1979 }
1980
1981 sub get_duedate {
1982   $main::lxdebug->enter_sub();
1983
1984   my ($self, $myconfig, $reference_date) = @_;
1985
1986   $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
1987
1988   my $dbh         = $self->get_standard_dbh($myconfig);
1989   my $payment_id;
1990
1991   if($self->{payment_id}) {
1992     $payment_id = $self->{payment_id};
1993   } elsif($self->{vendor_id}) {
1994     my $query = 'SELECT payment_id FROM vendor WHERE id = ?';
1995     ($payment_id) = selectrow_query($self, $dbh, $query, $self->{vendor_id});
1996   }
1997
1998   my $query       = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
1999   my ($duedate)   = selectrow_query($self, $dbh, $query, $payment_id);
2000
2001   $main::lxdebug->leave_sub();
2002
2003   return $duedate;
2004 }
2005
2006 sub _get_contacts {
2007   $main::lxdebug->enter_sub();
2008
2009   my ($self, $dbh, $id, $key) = @_;
2010
2011   $key = "all_contacts" unless ($key);
2012
2013   if (!$id) {
2014     $self->{$key} = [];
2015     $main::lxdebug->leave_sub();
2016     return;
2017   }
2018
2019   my $query =
2020     qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2021     qq|FROM contacts | .
2022     qq|WHERE cp_cv_id = ? | .
2023     qq|ORDER BY lower(cp_name)|;
2024
2025   $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2026
2027   $main::lxdebug->leave_sub();
2028 }
2029
2030 sub _get_projects {
2031   $main::lxdebug->enter_sub();
2032
2033   my ($self, $dbh, $key) = @_;
2034
2035   my ($all, $old_id, $where, @values);
2036
2037   if (ref($key) eq "HASH") {
2038     my $params = $key;
2039
2040     $key = "ALL_PROJECTS";
2041
2042     foreach my $p (keys(%{$params})) {
2043       if ($p eq "all") {
2044         $all = $params->{$p};
2045       } elsif ($p eq "old_id") {
2046         $old_id = $params->{$p};
2047       } elsif ($p eq "key") {
2048         $key = $params->{$p};
2049       }
2050     }
2051   }
2052
2053   if (!$all) {
2054     $where = "WHERE active ";
2055     if ($old_id) {
2056       if (ref($old_id) eq "ARRAY") {
2057         my @ids = grep({ $_ } @{$old_id});
2058         if (@ids) {
2059           $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2060           push(@values, @ids);
2061         }
2062       } else {
2063         $where .= " OR (id = ?) ";
2064         push(@values, $old_id);
2065       }
2066     }
2067   }
2068
2069   my $query =
2070     qq|SELECT id, projectnumber, description, active | .
2071     qq|FROM project | .
2072     $where .
2073     qq|ORDER BY lower(projectnumber)|;
2074
2075   $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2076
2077   $main::lxdebug->leave_sub();
2078 }
2079
2080 sub _get_shipto {
2081   $main::lxdebug->enter_sub();
2082
2083   my ($self, $dbh, $vc_id, $key) = @_;
2084
2085   $key = "all_shipto" unless ($key);
2086
2087   if ($vc_id) {
2088     # get shipping addresses
2089     my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2090
2091     $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2092
2093   } else {
2094     $self->{$key} = [];
2095   }
2096
2097   $main::lxdebug->leave_sub();
2098 }
2099
2100 sub _get_printers {
2101   $main::lxdebug->enter_sub();
2102
2103   my ($self, $dbh, $key) = @_;
2104
2105   $key = "all_printers" unless ($key);
2106
2107   my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2108
2109   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2110
2111   $main::lxdebug->leave_sub();
2112 }
2113
2114 sub _get_charts {
2115   $main::lxdebug->enter_sub();
2116
2117   my ($self, $dbh, $params) = @_;
2118   my ($key);
2119
2120   $key = $params->{key};
2121   $key = "all_charts" unless ($key);
2122
2123   my $transdate = quote_db_date($params->{transdate});
2124
2125   my $query =
2126     qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2127     qq|FROM chart c | .
2128     qq|LEFT JOIN taxkeys tk ON | .
2129     qq|(tk.id = (SELECT id FROM taxkeys | .
2130     qq|          WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2131     qq|          ORDER BY startdate DESC LIMIT 1)) | .
2132     qq|ORDER BY c.accno|;
2133
2134   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2135
2136   $main::lxdebug->leave_sub();
2137 }
2138
2139 sub _get_taxcharts {
2140   $main::lxdebug->enter_sub();
2141
2142   my ($self, $dbh, $params) = @_;
2143
2144   my $key = "all_taxcharts";
2145   my @where;
2146
2147   if (ref $params eq 'HASH') {
2148     $key = $params->{key} if ($params->{key});
2149     if ($params->{module} eq 'AR') {
2150       push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2151
2152     } elsif ($params->{module} eq 'AP') {
2153       push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2154     }
2155
2156   } elsif ($params) {
2157     $key = $params;
2158   }
2159
2160   my $where = @where ? ' WHERE ' . join(' AND ', map { "($_)" } @where) : '';
2161
2162   my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2163
2164   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2165
2166   $main::lxdebug->leave_sub();
2167 }
2168
2169 sub _get_taxzones {
2170   $main::lxdebug->enter_sub();
2171
2172   my ($self, $dbh, $key) = @_;
2173
2174   $key = "all_taxzones" unless ($key);
2175
2176   my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2177
2178   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2179
2180   $main::lxdebug->leave_sub();
2181 }
2182
2183 sub _get_employees {
2184   $main::lxdebug->enter_sub();
2185
2186   my ($self, $dbh, $default_key, $key) = @_;
2187
2188   $key = $default_key unless ($key);
2189   $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2190
2191   $main::lxdebug->leave_sub();
2192 }
2193
2194 sub _get_business_types {
2195   $main::lxdebug->enter_sub();
2196
2197   my ($self, $dbh, $key) = @_;
2198
2199   my $options       = ref $key eq 'HASH' ? $key : { key => $key };
2200   $options->{key} ||= "all_business_types";
2201   my $where         = '';
2202
2203   if (exists $options->{salesman}) {
2204     $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2205   }
2206
2207   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2208
2209   $main::lxdebug->leave_sub();
2210 }
2211
2212 sub _get_languages {
2213   $main::lxdebug->enter_sub();
2214
2215   my ($self, $dbh, $key) = @_;
2216
2217   $key = "all_languages" unless ($key);
2218
2219   my $query = qq|SELECT * FROM language ORDER BY id|;
2220
2221   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2222
2223   $main::lxdebug->leave_sub();
2224 }
2225
2226 sub _get_dunning_configs {
2227   $main::lxdebug->enter_sub();
2228
2229   my ($self, $dbh, $key) = @_;
2230
2231   $key = "all_dunning_configs" unless ($key);
2232
2233   my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2234
2235   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2236
2237   $main::lxdebug->leave_sub();
2238 }
2239
2240 sub _get_currencies {
2241 $main::lxdebug->enter_sub();
2242
2243   my ($self, $dbh, $key) = @_;
2244
2245   $key = "all_currencies" unless ($key);
2246
2247   my $query = qq|SELECT curr AS currency FROM defaults|;
2248
2249   $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2250
2251   $main::lxdebug->leave_sub();
2252 }
2253
2254 sub _get_payments {
2255 $main::lxdebug->enter_sub();
2256
2257   my ($self, $dbh, $key) = @_;
2258
2259   $key = "all_payments" unless ($key);
2260
2261   my $query = qq|SELECT * FROM payment_terms ORDER BY sortkey|;
2262
2263   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2264
2265   $main::lxdebug->leave_sub();
2266 }
2267
2268 sub _get_customers {
2269   $main::lxdebug->enter_sub();
2270
2271   my ($self, $dbh, $key) = @_;
2272
2273   my $options        = ref $key eq 'HASH' ? $key : { key => $key };
2274   $options->{key}  ||= "all_customers";
2275   my $limit_clause   = $options->{limit} ? "LIMIT $options->{limit}" : '';
2276
2277   my @where;
2278   push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if  $options->{business_is_salesman};
2279   push @where, qq|NOT obsolete|                                            if !$options->{with_obsolete};
2280   my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2281
2282   my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2283   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2284
2285   $main::lxdebug->leave_sub();
2286 }
2287
2288 sub _get_vendors {
2289   $main::lxdebug->enter_sub();
2290
2291   my ($self, $dbh, $key) = @_;
2292
2293   $key = "all_vendors" unless ($key);
2294
2295   my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2296
2297   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2298
2299   $main::lxdebug->leave_sub();
2300 }
2301
2302 sub _get_departments {
2303   $main::lxdebug->enter_sub();
2304
2305   my ($self, $dbh, $key) = @_;
2306
2307   $key = "all_departments" unless ($key);
2308
2309   my $query = qq|SELECT * FROM department ORDER BY description|;
2310
2311   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2312
2313   $main::lxdebug->leave_sub();
2314 }
2315
2316 sub _get_warehouses {
2317   $main::lxdebug->enter_sub();
2318
2319   my ($self, $dbh, $param) = @_;
2320
2321   my ($key, $bins_key);
2322
2323   if ('' eq ref $param) {
2324     $key = $param;
2325
2326   } else {
2327     $key      = $param->{key};
2328     $bins_key = $param->{bins};
2329   }
2330
2331   my $query = qq|SELECT w.* FROM warehouse w
2332                  WHERE (NOT w.invalid) AND
2333                    ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2334                  ORDER BY w.sortkey|;
2335
2336   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2337
2338   if ($bins_key) {
2339     $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?
2340                 ORDER BY description|;
2341     my $sth = prepare_query($self, $dbh, $query);
2342
2343     foreach my $warehouse (@{ $self->{$key} }) {
2344       do_statement($self, $sth, $query, $warehouse->{id});
2345       $warehouse->{$bins_key} = [];
2346
2347       while (my $ref = $sth->fetchrow_hashref()) {
2348         push @{ $warehouse->{$bins_key} }, $ref;
2349       }
2350     }
2351     $sth->finish();
2352   }
2353
2354   $main::lxdebug->leave_sub();
2355 }
2356
2357 sub _get_simple {
2358   $main::lxdebug->enter_sub();
2359
2360   my ($self, $dbh, $table, $key, $sortkey) = @_;
2361
2362   my $query  = qq|SELECT * FROM $table|;
2363   $query    .= qq| ORDER BY $sortkey| if ($sortkey);
2364
2365   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2366
2367   $main::lxdebug->leave_sub();
2368 }
2369
2370 #sub _get_groups {
2371 #  $main::lxdebug->enter_sub();
2372 #
2373 #  my ($self, $dbh, $key) = @_;
2374 #
2375 #  $key ||= "all_groups";
2376 #
2377 #  my $groups = $main::auth->read_groups();
2378 #
2379 #  $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2380 #
2381 #  $main::lxdebug->leave_sub();
2382 #}
2383
2384 sub get_lists {
2385   $main::lxdebug->enter_sub();
2386
2387   my $self = shift;
2388   my %params = @_;
2389
2390   my $dbh = $self->get_standard_dbh(\%main::myconfig);
2391   my ($sth, $query, $ref);
2392
2393   my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2394   my $vc_id = $self->{"${vc}_id"};
2395
2396   if ($params{"contacts"}) {
2397     $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2398   }
2399
2400   if ($params{"shipto"}) {
2401     $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2402   }
2403
2404   if ($params{"projects"} || $params{"all_projects"}) {
2405     $self->_get_projects($dbh, $params{"all_projects"} ?
2406                          $params{"all_projects"} : $params{"projects"},
2407                          $params{"all_projects"} ? 1 : 0);
2408   }
2409
2410   if ($params{"printers"}) {
2411     $self->_get_printers($dbh, $params{"printers"});
2412   }
2413
2414   if ($params{"languages"}) {
2415     $self->_get_languages($dbh, $params{"languages"});
2416   }
2417
2418   if ($params{"charts"}) {
2419     $self->_get_charts($dbh, $params{"charts"});
2420   }
2421
2422   if ($params{"taxcharts"}) {
2423     $self->_get_taxcharts($dbh, $params{"taxcharts"});
2424   }
2425
2426   if ($params{"taxzones"}) {
2427     $self->_get_taxzones($dbh, $params{"taxzones"});
2428   }
2429
2430   if ($params{"employees"}) {
2431     $self->_get_employees($dbh, "all_employees", $params{"employees"});
2432   }
2433
2434   if ($params{"salesmen"}) {
2435     $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2436   }
2437
2438   if ($params{"business_types"}) {
2439     $self->_get_business_types($dbh, $params{"business_types"});
2440   }
2441
2442   if ($params{"dunning_configs"}) {
2443     $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2444   }
2445
2446   if($params{"currencies"}) {
2447     $self->_get_currencies($dbh, $params{"currencies"});
2448   }
2449
2450   if($params{"customers"}) {
2451     $self->_get_customers($dbh, $params{"customers"});
2452   }
2453
2454   if($params{"vendors"}) {
2455     if (ref $params{"vendors"} eq 'HASH') {
2456       $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2457     } else {
2458       $self->_get_vendors($dbh, $params{"vendors"});
2459     }
2460   }
2461
2462   if($params{"payments"}) {
2463     $self->_get_payments($dbh, $params{"payments"});
2464   }
2465
2466   if($params{"departments"}) {
2467     $self->_get_departments($dbh, $params{"departments"});
2468   }
2469
2470   if ($params{price_factors}) {
2471     $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2472   }
2473
2474   if ($params{warehouses}) {
2475     $self->_get_warehouses($dbh, $params{warehouses});
2476   }
2477
2478 #  if ($params{groups}) {
2479 #    $self->_get_groups($dbh, $params{groups});
2480 #  }
2481
2482   if ($params{partsgroup}) {
2483     $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2484   }
2485
2486   $main::lxdebug->leave_sub();
2487 }
2488
2489 # this sub gets the id and name from $table
2490 sub get_name {
2491   $main::lxdebug->enter_sub();
2492
2493   my ($self, $myconfig, $table) = @_;
2494
2495   # connect to database
2496   my $dbh = $self->get_standard_dbh($myconfig);
2497
2498   $table = $table eq "customer" ? "customer" : "vendor";
2499   my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2500
2501   my ($query, @values);
2502
2503   if (!$self->{openinvoices}) {
2504     my $where;
2505     if ($self->{customernumber} ne "") {
2506       $where = qq|(vc.customernumber ILIKE ?)|;
2507       push(@values, '%' . $self->{customernumber} . '%');
2508     } else {
2509       $where = qq|(vc.name ILIKE ?)|;
2510       push(@values, '%' . $self->{$table} . '%');
2511     }
2512
2513     $query =
2514       qq~SELECT vc.id, vc.name,
2515            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2516          FROM $table vc
2517          WHERE $where AND (NOT vc.obsolete)
2518          ORDER BY vc.name~;
2519   } else {
2520     $query =
2521       qq~SELECT DISTINCT vc.id, vc.name,
2522            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2523          FROM $arap a
2524          JOIN $table vc ON (a.${table}_id = vc.id)
2525          WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2526          ORDER BY vc.name~;
2527     push(@values, '%' . $self->{$table} . '%');
2528   }
2529
2530   $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2531
2532   $main::lxdebug->leave_sub();
2533
2534   return scalar(@{ $self->{name_list} });
2535 }
2536
2537 # the selection sub is used in the AR, AP, IS, IR, DO and OE module
2538 #
2539 sub all_vc {
2540   $main::lxdebug->enter_sub();
2541
2542   my ($self, $myconfig, $table, $module) = @_;
2543
2544   my $ref;
2545   my $dbh = $self->get_standard_dbh;
2546
2547   $table = $table eq "customer" ? "customer" : "vendor";
2548
2549   # build selection list
2550   # Hotfix für Bug 1837 - Besser wäre es alte Buchungsbelege
2551   # OHNE Auswahlliste (reines Textfeld) zu laden. Hilft aber auch
2552   # nicht für veränderbare Belege (oe, do, ...)
2553   my $obsolete = "WHERE NOT obsolete" unless $self->{id};
2554   my $query = qq|SELECT count(*) FROM $table $obsolete|;
2555   my ($count) = selectrow_query($self, $dbh, $query);
2556
2557   if ($count < $myconfig->{vclimit}) {
2558     $query = qq|SELECT id, name, salesman_id
2559                 FROM $table $obsolete
2560                 ORDER BY name|;
2561     $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2562   }
2563
2564   # get self
2565   $self->get_employee($dbh);
2566
2567   # setup sales contacts
2568   $query = qq|SELECT e.id, e.name
2569               FROM employee e
2570               WHERE (e.sales = '1') AND (NOT e.id = ?)
2571               ORDER BY name|;
2572   $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2573
2574   # this is for self
2575   push(@{ $self->{all_employees} },
2576        { id   => $self->{employee_id},
2577          name => $self->{employee} });
2578
2579     # prepare query for departments
2580     $query = qq|SELECT id, description
2581                 FROM department
2582                 ORDER BY description|;
2583
2584   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2585
2586   # get languages
2587   $query = qq|SELECT id, description
2588               FROM language
2589               ORDER BY id|;
2590
2591   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2592
2593   # get printer
2594   $query = qq|SELECT printer_description, id
2595               FROM printers
2596               ORDER BY printer_description|;
2597
2598   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2599
2600   # get payment terms
2601   $query = qq|SELECT id, description
2602               FROM payment_terms
2603               ORDER BY sortkey|;
2604
2605   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2606
2607   $main::lxdebug->leave_sub();
2608 }
2609
2610 sub language_payment {
2611   $main::lxdebug->enter_sub();
2612
2613   my ($self, $myconfig) = @_;
2614
2615   my $dbh = $self->get_standard_dbh($myconfig);
2616   # get languages
2617   my $query = qq|SELECT id, description
2618                  FROM language
2619                  ORDER BY id|;
2620
2621   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2622
2623   # get printer
2624   $query = qq|SELECT printer_description, id
2625               FROM printers
2626               ORDER BY printer_description|;
2627
2628   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2629
2630   # get payment terms
2631   $query = qq|SELECT id, description
2632               FROM payment_terms
2633               ORDER BY sortkey|;
2634
2635   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2636
2637   # get buchungsgruppen
2638   $query = qq|SELECT id, description
2639               FROM buchungsgruppen|;
2640
2641   $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2642
2643   $main::lxdebug->leave_sub();
2644 }
2645
2646 # this is only used for reports
2647 sub all_departments {
2648   $main::lxdebug->enter_sub();
2649
2650   my ($self, $myconfig, $table) = @_;
2651
2652   my $dbh = $self->get_standard_dbh($myconfig);
2653
2654   my $query = qq|SELECT id, description
2655                  FROM department
2656                  ORDER BY description|;
2657   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2658
2659   delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2660
2661   $main::lxdebug->leave_sub();
2662 }
2663
2664 sub create_links {
2665   $main::lxdebug->enter_sub();
2666
2667   my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2668
2669   my ($fld, $arap);
2670   if ($table eq "customer") {
2671     $fld = "buy";
2672     $arap = "ar";
2673   } else {
2674     $table = "vendor";
2675     $fld = "sell";
2676     $arap = "ap";
2677   }
2678
2679   $self->all_vc($myconfig, $table, $module);
2680
2681   # get last customers or vendors
2682   my ($query, $sth, $ref);
2683
2684   my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2685   my %xkeyref = ();
2686
2687   if (!$self->{id}) {
2688
2689     my $transdate = "current_date";
2690     if ($self->{transdate}) {
2691       $transdate = $dbh->quote($self->{transdate});
2692     }
2693
2694     # now get the account numbers
2695 #    $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2696 #                FROM chart c, taxkeys tk
2697 #                WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2698 #                  (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2699 #                ORDER BY c.accno|;
2700
2701 #  same query as above, but without expensive subquery for each row. about 80% faster
2702     $query = qq|
2703       SELECT c.accno, c.description, c.link, c.taxkey_id, tk2.tax_id
2704         FROM chart c
2705         -- find newest entries in taxkeys
2706         INNER JOIN (
2707           SELECT chart_id, MAX(startdate) AS startdate
2708           FROM taxkeys
2709           WHERE (startdate <= $transdate)
2710           GROUP BY chart_id
2711         ) tk ON (c.id = tk.chart_id)
2712         -- and load all of those entries
2713         INNER JOIN taxkeys tk2
2714            ON (tk.chart_id = tk2.chart_id AND tk.startdate = tk2.startdate)
2715        WHERE (c.link LIKE ?)
2716       ORDER BY c.accno|;
2717
2718     $sth = $dbh->prepare($query);
2719
2720     do_statement($self, $sth, $query, '%' . $module . '%');
2721
2722     $self->{accounts} = "";
2723     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2724
2725       foreach my $key (split(/:/, $ref->{link})) {
2726         if ($key =~ /\Q$module\E/) {
2727
2728           # cross reference for keys
2729           $xkeyref{ $ref->{accno} } = $key;
2730
2731           push @{ $self->{"${module}_links"}{$key} },
2732             { accno       => $ref->{accno},
2733               description => $ref->{description},
2734               taxkey      => $ref->{taxkey_id},
2735               tax_id      => $ref->{tax_id} };
2736
2737           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2738         }
2739       }
2740     }
2741   }
2742
2743   # get taxkeys and description
2744   $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2745   $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2746
2747   if (($module eq "AP") || ($module eq "AR")) {
2748     # get tax rates and description
2749     $query = qq|SELECT * FROM tax|;
2750     $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2751   }
2752
2753   if ($self->{id}) {
2754     $query =
2755       qq|SELECT
2756            a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2757            a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2758            a.intnotes, a.department_id, a.amount AS oldinvtotal,
2759            a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2760            a.globalproject_id,
2761            c.name AS $table,
2762            d.description AS department,
2763            e.name AS employee
2764          FROM $arap a
2765          JOIN $table c ON (a.${table}_id = c.id)
2766          LEFT JOIN employee e ON (e.id = a.employee_id)
2767          LEFT JOIN department d ON (d.id = a.department_id)
2768          WHERE a.id = ?|;
2769     $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2770
2771     foreach my $key (keys %$ref) {
2772       $self->{$key} = $ref->{$key};
2773     }
2774
2775     # remove any trailing whitespace
2776     $self->{currency} =~ s/\s*$//;
2777
2778     my $transdate = "current_date";
2779     if ($self->{transdate}) {
2780       $transdate = $dbh->quote($self->{transdate});
2781     }
2782
2783     # now get the account numbers
2784     $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2785                 FROM chart c
2786                 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2787                 WHERE c.link LIKE ?
2788                   AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2789                     OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2790                 ORDER BY c.accno|;
2791
2792     $sth = $dbh->prepare($query);
2793     do_statement($self, $sth, $query, "%$module%");
2794
2795     $self->{accounts} = "";
2796     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2797
2798       foreach my $key (split(/:/, $ref->{link})) {
2799         if ($key =~ /\Q$module\E/) {
2800
2801           # cross reference for keys
2802           $xkeyref{ $ref->{accno} } = $key;
2803
2804           push @{ $self->{"${module}_links"}{$key} },
2805             { accno       => $ref->{accno},
2806               description => $ref->{description},
2807               taxkey      => $ref->{taxkey_id},
2808               tax_id      => $ref->{tax_id} };
2809
2810           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2811         }
2812       }
2813     }
2814
2815
2816     # get amounts from individual entries
2817     $query =
2818       qq|SELECT
2819            c.accno, c.description,
2820            a.acc_trans_id, a.source, a.amount, a.memo, a.transdate, a.gldate, a.cleared, a.project_id, a.taxkey,
2821            p.projectnumber,
2822            t.rate, t.id
2823          FROM acc_trans a
2824          LEFT JOIN chart c ON (c.id = a.chart_id)
2825          LEFT JOIN project p ON (p.id = a.project_id)
2826          LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2827                                     WHERE (tk.taxkey_id=a.taxkey) AND
2828                                       ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2829                                         THEN tk.chart_id = a.chart_id
2830                                         ELSE 1 = 1
2831                                         END)
2832                                        OR (c.link='%tax%')) AND
2833                                       (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2834          WHERE a.trans_id = ?
2835          AND a.fx_transaction = '0'
2836          ORDER BY a.acc_trans_id, a.transdate|;
2837     $sth = $dbh->prepare($query);
2838     do_statement($self, $sth, $query, $self->{id});
2839
2840     # get exchangerate for currency
2841     $self->{exchangerate} =
2842       $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2843     my $index = 0;
2844
2845     # store amounts in {acc_trans}{$key} for multiple accounts
2846     while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2847       $ref->{exchangerate} =
2848         $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2849       if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2850         $index++;
2851       }
2852       if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2853         $ref->{amount} *= -1;
2854       }
2855       $ref->{index} = $index;
2856
2857       push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2858     }
2859
2860     $sth->finish;
2861     $query =
2862       qq|SELECT
2863            d.curr AS currencies, d.closedto, d.revtrans,
2864            (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2865            (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2866          FROM defaults d|;
2867     $ref = selectfirst_hashref_query($self, $dbh, $query);
2868     map { $self->{$_} = $ref->{$_} } keys %$ref;
2869
2870   } else {
2871
2872     # get date
2873     $query =
2874        qq|SELECT
2875             current_date AS transdate, 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     if ($self->{"$self->{vc}_id"}) {
2883
2884       # only setup currency
2885       ($self->{currency}) = split(/:/, $self->{currencies}) if !$self->{currency};
2886
2887     } else {
2888
2889       $self->lastname_used($dbh, $myconfig, $table, $module);
2890
2891       # get exchangerate for currency
2892       $self->{exchangerate} =
2893         $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2894
2895     }
2896
2897   }
2898
2899   $main::lxdebug->leave_sub();
2900 }
2901
2902 sub lastname_used {
2903   $main::lxdebug->enter_sub();
2904
2905   my ($self, $dbh, $myconfig, $table, $module) = @_;
2906
2907   my ($arap, $where);
2908
2909   $table         = $table eq "customer" ? "customer" : "vendor";
2910   my %column_map = ("a.curr"                  => "currency",
2911                     "a.${table}_id"           => "${table}_id",
2912                     "a.department_id"         => "department_id",
2913                     "d.description"           => "department",
2914                     "ct.name"                 => $table,
2915                     "ct.curr"                 => "cv_curr",
2916                     "current_date + ct.terms" => "duedate",
2917     );
2918
2919   if ($self->{type} =~ /delivery_order/) {
2920     $arap  = 'delivery_orders';
2921     delete $column_map{"a.curr"};
2922     delete $column_map{"ct.curr"};
2923
2924   } elsif ($self->{type} =~ /_order/) {
2925     $arap  = 'oe';
2926     $where = "quotation = '0'";
2927
2928   } elsif ($self->{type} =~ /_quotation/) {
2929     $arap  = 'oe';
2930     $where = "quotation = '1'";
2931
2932   } elsif ($table eq 'customer') {
2933     $arap  = 'ar';
2934
2935   } else {
2936     $arap  = 'ap';
2937
2938   }
2939
2940   $where           = "($where) AND" if ($where);
2941   my $query        = qq|SELECT MAX(id) FROM $arap
2942                         WHERE $where ${table}_id > 0|;
2943   my ($trans_id)   = selectrow_query($self, $dbh, $query);
2944   $trans_id       *= 1;
2945
2946   my $column_spec  = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
2947   $query           = qq|SELECT $column_spec
2948                         FROM $arap a
2949                         LEFT JOIN $table     ct ON (a.${table}_id = ct.id)
2950                         LEFT JOIN department d  ON (a.department_id = d.id)
2951                         WHERE a.id = ?|;
2952   my $ref          = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
2953
2954   map { $self->{$_} = $ref->{$_} } values %column_map;
2955
2956   # remove any trailing whitespace
2957   $self->{currency} =~ s/\s*$// if $self->{currency};
2958   $self->{cv_curr} =~ s/\s*$// if $self->{cv_curr};
2959
2960   # if customer/vendor currency is set use this
2961   $self->{currency} = $self->{cv_curr} if $self->{cv_curr};
2962
2963   $main::lxdebug->leave_sub();
2964 }
2965
2966 sub current_date {
2967   $main::lxdebug->enter_sub();
2968
2969   my $self     = shift;
2970   my $myconfig = shift || \%::myconfig;
2971   my ($thisdate, $days) = @_;
2972
2973   my $dbh = $self->get_standard_dbh($myconfig);
2974   my $query;
2975
2976   $days *= 1;
2977   if ($thisdate) {
2978     my $dateformat = $myconfig->{dateformat};
2979     $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
2980     $thisdate = $dbh->quote($thisdate);
2981     $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
2982   } else {
2983     $query = qq|SELECT current_date AS thisdate|;
2984   }
2985
2986   ($thisdate) = selectrow_query($self, $dbh, $query);
2987
2988   $main::lxdebug->leave_sub();
2989
2990   return $thisdate;
2991 }
2992
2993 sub like {
2994   $main::lxdebug->enter_sub();
2995
2996   my ($self, $string) = @_;
2997
2998   if ($string !~ /%/) {
2999     $string = "%$string%";
3000   }
3001
3002   $string =~ s/\'/\'\'/g;
3003
3004   $main::lxdebug->leave_sub();
3005
3006   return $string;
3007 }
3008
3009 sub redo_rows {
3010   $main::lxdebug->enter_sub();
3011
3012   my ($self, $flds, $new, $count, $numrows) = @_;
3013
3014   my @ndx = ();
3015
3016   map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3017
3018   my $i = 0;
3019
3020   # fill rows
3021   foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3022     $i++;
3023     my $j = $item->{ndx} - 1;
3024     map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3025   }
3026
3027   # delete empty rows
3028   for $i ($count + 1 .. $numrows) {
3029     map { delete $self->{"${_}_$i"} } @{$flds};
3030   }
3031
3032   $main::lxdebug->leave_sub();
3033 }
3034
3035 sub update_status {
3036   $main::lxdebug->enter_sub();
3037
3038   my ($self, $myconfig) = @_;
3039
3040   my ($i, $id);
3041
3042   my $dbh = $self->dbconnect_noauto($myconfig);
3043
3044   my $query = qq|DELETE FROM status
3045                  WHERE (formname = ?) AND (trans_id = ?)|;
3046   my $sth = prepare_query($self, $dbh, $query);
3047
3048   if ($self->{formname} =~ /(check|receipt)/) {
3049     for $i (1 .. $self->{rowcount}) {
3050       do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3051     }
3052   } else {
3053     do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3054   }
3055   $sth->finish();
3056
3057   my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3058   my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3059
3060   my %queued = split / /, $self->{queued};
3061   my @values;
3062
3063   if ($self->{formname} =~ /(check|receipt)/) {
3064
3065     # this is a check or receipt, add one entry for each lineitem
3066     my ($accno) = split /--/, $self->{account};
3067     $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3068                 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3069     @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3070     $sth = prepare_query($self, $dbh, $query);
3071
3072     for $i (1 .. $self->{rowcount}) {
3073       if ($self->{"checked_$i"}) {
3074         do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3075       }
3076     }
3077     $sth->finish();
3078
3079   } else {
3080     $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3081                 VALUES (?, ?, ?, ?, ?)|;
3082     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3083              $queued{$self->{formname}}, $self->{formname});
3084   }
3085
3086   $dbh->commit;
3087   $dbh->disconnect;
3088
3089   $main::lxdebug->leave_sub();
3090 }
3091
3092 sub save_status {
3093   $main::lxdebug->enter_sub();
3094
3095   my ($self, $dbh) = @_;
3096
3097   my ($query, $printed, $emailed);
3098
3099   my $formnames  = $self->{printed};
3100   my $emailforms = $self->{emailed};
3101
3102   $query = qq|DELETE FROM status
3103                  WHERE (formname = ?) AND (trans_id = ?)|;
3104   do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3105
3106   # this only applies to the forms
3107   # checks and receipts are posted when printed or queued
3108
3109   if ($self->{queued}) {
3110     my %queued = split / /, $self->{queued};
3111
3112     foreach my $formname (keys %queued) {
3113       $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3114       $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3115
3116       $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3117                   VALUES (?, ?, ?, ?, ?)|;
3118       do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3119
3120       $formnames  =~ s/\Q$self->{formname}\E//;
3121       $emailforms =~ s/\Q$self->{formname}\E//;
3122
3123     }
3124   }
3125
3126   # save printed, emailed info
3127   $formnames  =~ s/^ +//g;
3128   $emailforms =~ s/^ +//g;
3129
3130   my %status = ();
3131   map { $status{$_}{printed} = 1 } split / +/, $formnames;
3132   map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3133
3134   foreach my $formname (keys %status) {
3135     $printed = ($formnames  =~ /\Q$self->{formname}\E/) ? "1" : "0";
3136     $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3137
3138     $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3139                 VALUES (?, ?, ?, ?)|;
3140     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3141   }
3142
3143   $main::lxdebug->leave_sub();
3144 }
3145
3146 #--- 4 locale ---#
3147 # $main::locale->text('SAVED')
3148 # $main::locale->text('DELETED')
3149 # $main::locale->text('ADDED')
3150 # $main::locale->text('PAYMENT POSTED')
3151 # $main::locale->text('POSTED')
3152 # $main::locale->text('POSTED AS NEW')
3153 # $main::locale->text('ELSE')
3154 # $main::locale->text('SAVED FOR DUNNING')
3155 # $main::locale->text('DUNNING STARTED')
3156 # $main::locale->text('PRINTED')
3157 # $main::locale->text('MAILED')
3158 # $main::locale->text('SCREENED')
3159 # $main::locale->text('CANCELED')
3160 # $main::locale->text('invoice')
3161 # $main::locale->text('proforma')
3162 # $main::locale->text('sales_order')
3163 # $main::locale->text('pick_list')
3164 # $main::locale->text('purchase_order')
3165 # $main::locale->text('bin_list')
3166 # $main::locale->text('sales_quotation')
3167 # $main::locale->text('request_quotation')
3168
3169 sub save_history {
3170   $main::lxdebug->enter_sub();
3171
3172   my $self = shift;
3173   my $dbh  = shift || $self->get_standard_dbh;
3174
3175   if(!exists $self->{employee_id}) {
3176     &get_employee($self, $dbh);
3177   }
3178
3179   my $query =
3180    qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3181    qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3182   my @values = (conv_i($self->{id}), $self->{login},
3183                 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3184   do_query($self, $dbh, $query, @values);
3185
3186   $dbh->commit;
3187
3188   $main::lxdebug->leave_sub();
3189 }
3190
3191 sub get_history {
3192   $main::lxdebug->enter_sub();
3193
3194   my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3195   my ($orderBy, $desc) = split(/\-\-/, $order);
3196   $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3197   my @tempArray;
3198   my $i = 0;
3199   if ($trans_id ne "") {
3200     my $query =
3201       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 | .
3202       qq|FROM history_erp h | .
3203       qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3204       qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3205       $order;
3206
3207     my $sth = $dbh->prepare($query) || $self->dberror($query);
3208
3209     $sth->execute() || $self->dberror("$query");
3210
3211     while(my $hash_ref = $sth->fetchrow_hashref()) {
3212       $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3213       $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3214       $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3215       $tempArray[$i++] = $hash_ref;
3216     }
3217     $main::lxdebug->leave_sub() and return \@tempArray
3218       if ($i > 0 && $tempArray[0] ne "");
3219   }
3220   $main::lxdebug->leave_sub();
3221   return 0;
3222 }
3223
3224 sub update_defaults {
3225   $main::lxdebug->enter_sub();
3226
3227   my ($self, $myconfig, $fld, $provided_dbh) = @_;
3228
3229   my $dbh;
3230   if ($provided_dbh) {
3231     $dbh = $provided_dbh;
3232   } else {
3233     $dbh = $self->dbconnect_noauto($myconfig);
3234   }
3235   my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3236   my $sth   = $dbh->prepare($query);
3237
3238   $sth->execute || $self->dberror($query);
3239   my ($var) = $sth->fetchrow_array;
3240   $sth->finish;
3241
3242   if ($var =~ m/\d+$/) {
3243     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3244     my $len_diff = length($var) - $-[0] - length($new_var);
3245     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3246
3247   } else {
3248     $var = $var . '1';
3249   }
3250
3251   $query = qq|UPDATE defaults SET $fld = ?|;
3252   do_query($self, $dbh, $query, $var);
3253
3254   if (!$provided_dbh) {
3255     $dbh->commit;
3256     $dbh->disconnect;
3257   }
3258
3259   $main::lxdebug->leave_sub();
3260
3261   return $var;
3262 }
3263
3264 sub update_business {
3265   $main::lxdebug->enter_sub();
3266
3267   my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3268
3269   my $dbh;
3270   if ($provided_dbh) {
3271     $dbh = $provided_dbh;
3272   } else {
3273     $dbh = $self->dbconnect_noauto($myconfig);
3274   }
3275   my $query =
3276     qq|SELECT customernumberinit FROM business
3277        WHERE id = ? FOR UPDATE|;
3278   my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3279
3280   return undef unless $var;
3281
3282   if ($var =~ m/\d+$/) {
3283     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3284     my $len_diff = length($var) - $-[0] - length($new_var);
3285     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3286
3287   } else {
3288     $var = $var . '1';
3289   }
3290
3291   $query = qq|UPDATE business
3292               SET customernumberinit = ?
3293               WHERE id = ?|;
3294   do_query($self, $dbh, $query, $var, $business_id);
3295
3296   if (!$provided_dbh) {
3297     $dbh->commit;
3298     $dbh->disconnect;
3299   }
3300
3301   $main::lxdebug->leave_sub();
3302
3303   return $var;
3304 }
3305
3306 sub get_partsgroup {
3307   $main::lxdebug->enter_sub();
3308
3309   my ($self, $myconfig, $p) = @_;
3310   my $target = $p->{target} || 'all_partsgroup';
3311
3312   my $dbh = $self->get_standard_dbh($myconfig);
3313
3314   my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3315                  FROM partsgroup pg
3316                  JOIN parts p ON (p.partsgroup_id = pg.id) |;
3317   my @values;
3318
3319   if ($p->{searchitems} eq 'part') {
3320     $query .= qq|WHERE p.inventory_accno_id > 0|;
3321   }
3322   if ($p->{searchitems} eq 'service') {
3323     $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3324   }
3325   if ($p->{searchitems} eq 'assembly') {
3326     $query .= qq|WHERE p.assembly = '1'|;
3327   }
3328   if ($p->{searchitems} eq 'labor') {
3329     $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3330   }
3331
3332   $query .= qq|ORDER BY partsgroup|;
3333
3334   if ($p->{all}) {
3335     $query = qq|SELECT id, partsgroup FROM partsgroup
3336                 ORDER BY partsgroup|;
3337   }
3338
3339   if ($p->{language_code}) {
3340     $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3341                   t.description AS translation
3342                 FROM partsgroup pg
3343                 JOIN parts p ON (p.partsgroup_id = pg.id)
3344                 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3345                 ORDER BY translation|;
3346     @values = ($p->{language_code});
3347   }
3348
3349   $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3350
3351   $main::lxdebug->leave_sub();
3352 }
3353
3354 sub get_pricegroup {
3355   $main::lxdebug->enter_sub();
3356
3357   my ($self, $myconfig, $p) = @_;
3358
3359   my $dbh = $self->get_standard_dbh($myconfig);
3360
3361   my $query = qq|SELECT p.id, p.pricegroup
3362                  FROM pricegroup p|;
3363
3364   $query .= qq| ORDER BY pricegroup|;
3365
3366   if ($p->{all}) {
3367     $query = qq|SELECT id, pricegroup FROM pricegroup
3368                 ORDER BY pricegroup|;
3369   }
3370
3371   $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3372
3373   $main::lxdebug->leave_sub();
3374 }
3375
3376 sub all_years {
3377 # usage $form->all_years($myconfig, [$dbh])
3378 # return list of all years where bookings found
3379 # (@all_years)
3380
3381   $main::lxdebug->enter_sub();
3382
3383   my ($self, $myconfig, $dbh) = @_;
3384
3385   $dbh ||= $self->get_standard_dbh($myconfig);
3386
3387   # get years
3388   my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3389                    (SELECT MAX(transdate) FROM acc_trans)|;
3390   my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3391
3392   if ($myconfig->{dateformat} =~ /^yy/) {
3393     ($startdate) = split /\W/, $startdate;
3394     ($enddate) = split /\W/, $enddate;
3395   } else {
3396     (@_) = split /\W/, $startdate;
3397     $startdate = $_[2];
3398     (@_) = split /\W/, $enddate;
3399     $enddate = $_[2];
3400   }
3401
3402   my @all_years;
3403   $startdate = substr($startdate,0,4);
3404   $enddate = substr($enddate,0,4);
3405
3406   while ($enddate >= $startdate) {
3407     push @all_years, $enddate--;
3408   }
3409
3410   return @all_years;
3411
3412   $main::lxdebug->leave_sub();
3413 }
3414
3415 sub backup_vars {
3416   $main::lxdebug->enter_sub();
3417   my $self = shift;
3418   my @vars = @_;
3419
3420   map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3421
3422   $main::lxdebug->leave_sub();
3423 }
3424
3425 sub restore_vars {
3426   $main::lxdebug->enter_sub();
3427
3428   my $self = shift;
3429   my @vars = @_;
3430
3431   map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3432
3433   $main::lxdebug->leave_sub();
3434 }
3435
3436 sub prepare_for_printing {
3437   my ($self) = @_;
3438
3439   $self->{templates} ||= $::myconfig{templates};
3440   $self->{formname}  ||= $self->{type};
3441   $self->{media}     ||= 'email';
3442
3443   die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3444
3445   # set shipto from billto unless set
3446   my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3447   if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3448     $self->{shiptoname}   = $::myconfig{company};
3449     $self->{shiptostreet} = $::myconfig{address};
3450   }
3451
3452   my $language = $self->{language} ? '_' . $self->{language} : '';
3453
3454   my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3455   if ($self->{language_id}) {
3456     ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3457   } else {
3458     $output_dateformat   = $::myconfig{dateformat};
3459     $output_numberformat = $::myconfig{numberformat};
3460     $output_longdates    = 1;
3461   }
3462
3463   # Retrieve accounts for tax calculation.
3464   IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3465
3466   if ($self->{type} =~ /_delivery_order$/) {
3467     DO->order_details();
3468   } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3469     OE->order_details(\%::myconfig, $self);
3470   } else {
3471     IS->invoice_details(\%::myconfig, $self, $::locale);
3472   }
3473
3474   # Chose extension & set source file name
3475   my $extension = 'html';
3476   if ($self->{format} eq 'postscript') {
3477     $self->{postscript}   = 1;
3478     $extension            = 'tex';
3479   } elsif ($self->{"format"} =~ /pdf/) {
3480     $self->{pdf}          = 1;
3481     $extension            = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3482   } elsif ($self->{"format"} =~ /opendocument/) {
3483     $self->{opendocument} = 1;
3484     $extension            = 'odt';
3485   } elsif ($self->{"format"} =~ /excel/) {
3486     $self->{excel}        = 1;
3487     $extension            = 'xls';
3488   }
3489
3490   my $printer_code    = $self->{printer_code} ? '_' . $self->{printer_code} : '';
3491   my $email_extension = -f "$::myconfig{templates}/$self->{formname}_email${language}.${extension}" ? '_email' : '';
3492   $self->{IN}         = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3493
3494   # Format dates.
3495   $self->format_dates($output_dateformat, $output_longdates,
3496                       qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3497                          transdate_oe deliverydate_oe employee_startdate employee_enddate),
3498                       grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3499
3500   $self->reformat_numbers($output_numberformat, 2,
3501                           qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3502                           grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3503
3504   $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3505
3506   my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3507
3508   if (scalar @{ $cvar_date_fields }) {
3509     $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3510   }
3511
3512   while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3513     $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3514   }
3515
3516   return $self;
3517 }
3518
3519 sub format_dates {
3520   my ($self, $dateformat, $longformat, @indices) = @_;
3521
3522   $dateformat ||= $::myconfig{dateformat};
3523
3524   foreach my $idx (@indices) {
3525     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3526       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3527         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3528       }
3529     }
3530
3531     next unless defined $self->{$idx};
3532
3533     if (!ref($self->{$idx})) {
3534       $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3535
3536     } elsif (ref($self->{$idx}) eq "ARRAY") {
3537       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3538         $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3539       }
3540     }
3541   }
3542 }
3543
3544 sub reformat_numbers {
3545   my ($self, $numberformat, $places, @indices) = @_;
3546
3547   return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3548
3549   foreach my $idx (@indices) {
3550     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3551       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3552         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3553       }
3554     }
3555
3556     next unless defined $self->{$idx};
3557
3558     if (!ref($self->{$idx})) {
3559       $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3560
3561     } elsif (ref($self->{$idx}) eq "ARRAY") {
3562       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3563         $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3564       }
3565     }
3566   }
3567
3568   my $saved_numberformat    = $::myconfig{numberformat};
3569   $::myconfig{numberformat} = $numberformat;
3570
3571   foreach my $idx (@indices) {
3572     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3573       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3574         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3575       }
3576     }
3577
3578     next unless defined $self->{$idx};
3579
3580     if (!ref($self->{$idx})) {
3581       $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3582
3583     } elsif (ref($self->{$idx}) eq "ARRAY") {
3584       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3585         $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3586       }
3587     }
3588   }
3589
3590   $::myconfig{numberformat} = $saved_numberformat;
3591 }
3592
3593 1;
3594
3595 __END__
3596
3597 =head1 NAME
3598
3599 SL::Form.pm - main data object.
3600
3601 =head1 SYNOPSIS
3602
3603 This is the main data object of Lx-Office.
3604 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3605 Points of interest for a beginner are:
3606
3607  - $form->error            - renders a generic error in html. accepts an error message
3608  - $form->get_standard_dbh - returns a database connection for the
3609
3610 =head1 SPECIAL FUNCTIONS
3611
3612 =head2 C<update_business> PARAMS
3613
3614 PARAMS (not named):
3615  \%config,     - config hashref
3616  $business_id, - business id
3617  $dbh          - optional database handle
3618
3619 handles business (thats customer/vendor types) sequences.
3620
3621 special behaviour for empty strings in customerinitnumber field:
3622 will in this case not increase the value, and return undef.
3623
3624 =head2 C<redirect_header> $url
3625
3626 Generates a HTTP redirection header for the new C<$url>. Constructs an
3627 absolute URL including scheme, host name and port. If C<$url> is a
3628 relative URL then it is considered relative to Lx-Office base URL.
3629
3630 This function C<die>s if headers have already been created with
3631 C<$::form-E<gt>header>.
3632
3633 Examples:
3634
3635   print $::form->redirect_header('oe.pl?action=edit&id=1234');
3636   print $::form->redirect_header('http://www.lx-office.org/');
3637
3638 =head2 C<header>
3639
3640 Generates a general purpose http/html header and includes most of the scripts
3641 and stylesheets needed. Stylesheets can be added with L<use_stylesheet>.
3642
3643 Only one header will be generated. If the method was already called in this
3644 request it will not output anything and return undef. Also if no
3645 HTTP_USER_AGENT is found, no header is generated.
3646
3647 Although header does not accept parameters itself, it will honor special
3648 hashkeys of its Form instance:
3649
3650 =over 4
3651
3652 =item refresh_time
3653
3654 =item refresh_url
3655
3656 If one of these is set, a http-equiv refresh is generated. Missing parameters
3657 default to 3 seconds and the refering url.
3658
3659 =item stylesheet
3660
3661 Either a scalar or an array ref. Will be inlined into the header. Add
3662 stylesheets with the L<use_stylesheet> function.
3663
3664 =item landscape
3665
3666 If true, a css snippet will be generated that sets the page in landscape mode.
3667
3668 =item favicon
3669
3670 Used to override the default favicon.
3671
3672 =item title
3673
3674 A html page title will be generated from this
3675
3676 =back
3677
3678 =cut