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