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