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