SL/Form.pm

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