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