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