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