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