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