SL/Form.pm

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