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