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