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