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