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   if ($module eq 'AR') {
2761
2762     # prepare query for departments
2763     $query = qq|SELECT id, description
2764                 FROM department
2765                 WHERE role = 'P'
2766                 ORDER BY description|;
2767
2768   } else {
2769     $query = qq|SELECT id, description
2770                 FROM department
2771                 ORDER BY description|;
2772   }
2773
2774   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2775
2776   # get languages
2777   $query = qq|SELECT id, description
2778               FROM language
2779               ORDER BY id|;
2780
2781   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2782
2783   # get printer
2784   $query = qq|SELECT printer_description, id
2785               FROM printers
2786               ORDER BY printer_description|;
2787
2788   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2789
2790   # get payment terms
2791   $query = qq|SELECT id, description
2792               FROM payment_terms
2793               ORDER BY sortkey|;
2794
2795   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2796
2797   $main::lxdebug->leave_sub();
2798 }
2799
2800 sub language_payment {
2801   $main::lxdebug->enter_sub();
2802
2803   my ($self, $myconfig) = @_;
2804
2805   my $dbh = $self->get_standard_dbh($myconfig);
2806   # get languages
2807   my $query = qq|SELECT id, description
2808                  FROM language
2809                  ORDER BY id|;
2810
2811   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2812
2813   # get printer
2814   $query = qq|SELECT printer_description, id
2815               FROM printers
2816               ORDER BY printer_description|;
2817
2818   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2819
2820   # get payment terms
2821   $query = qq|SELECT id, description
2822               FROM payment_terms
2823               ORDER BY sortkey|;
2824
2825   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2826
2827   # get buchungsgruppen
2828   $query = qq|SELECT id, description
2829               FROM buchungsgruppen|;
2830
2831   $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2832
2833   $main::lxdebug->leave_sub();
2834 }
2835
2836 # this is only used for reports
2837 sub all_departments {
2838   $main::lxdebug->enter_sub();
2839
2840   my ($self, $myconfig, $table) = @_;
2841
2842   my $dbh = $self->get_standard_dbh($myconfig);
2843   my $where;
2844
2845   if ($table eq 'customer') {
2846     $where = "WHERE role = 'P' ";
2847   }
2848
2849   my $query = qq|SELECT id, description
2850                  FROM department
2851                  $where
2852                  ORDER BY description|;
2853   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2854
2855   delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2856
2857   $main::lxdebug->leave_sub();
2858 }
2859
2860 sub create_links {
2861   $main::lxdebug->enter_sub();
2862
2863   my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2864
2865   my ($fld, $arap);
2866   if ($table eq "customer") {
2867     $fld = "buy";
2868     $arap = "ar";
2869   } else {
2870     $table = "vendor";
2871     $fld = "sell";
2872     $arap = "ap";
2873   }
2874
2875   $self->all_vc($myconfig, $table, $module);
2876
2877   # get last customers or vendors
2878   my ($query, $sth, $ref);
2879
2880   my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2881   my %xkeyref = ();
2882
2883   if (!$self->{id}) {
2884
2885     my $transdate = "current_date";
2886     if ($self->{transdate}) {
2887       $transdate = $dbh->quote($self->{transdate});
2888     }
2889
2890     # now get the account numbers
2891 #    $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2892 #                FROM chart c, taxkeys tk
2893 #                WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2894 #                  (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2895 #                ORDER BY c.accno|;
2896
2897 #  same query as above, but without expensive subquery for each row. about 80% faster
2898     $query = qq|
2899       SELECT c.accno, c.description, c.link, c.taxkey_id, tk2.tax_id
2900         FROM chart c
2901         -- find newest entries in taxkeys
2902         INNER JOIN (
2903           SELECT chart_id, MAX(startdate) AS startdate
2904           FROM taxkeys
2905           WHERE (startdate <= $transdate)
2906           GROUP BY chart_id
2907         ) tk ON (c.id = tk.chart_id)
2908         -- and load all of those entries
2909         INNER JOIN taxkeys tk2
2910            ON (tk.chart_id = tk2.chart_id AND tk.startdate = tk2.startdate)
2911        WHERE (c.link LIKE ?)
2912       ORDER BY c.accno|;
2913
2914     $sth = $dbh->prepare($query);
2915
2916     do_statement($self, $sth, $query, '%' . $module . '%');
2917
2918     $self->{accounts} = "";
2919     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2920
2921       foreach my $key (split(/:/, $ref->{link})) {
2922         if ($key =~ /\Q$module\E/) {
2923
2924           # cross reference for keys
2925           $xkeyref{ $ref->{accno} } = $key;
2926
2927           push @{ $self->{"${module}_links"}{$key} },
2928             { accno       => $ref->{accno},
2929               description => $ref->{description},
2930               taxkey      => $ref->{taxkey_id},
2931               tax_id      => $ref->{tax_id} };
2932
2933           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2934         }
2935       }
2936     }
2937   }
2938
2939   # get taxkeys and description
2940   $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2941   $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2942
2943   if (($module eq "AP") || ($module eq "AR")) {
2944     # get tax rates and description
2945     $query = qq|SELECT * FROM tax|;
2946     $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2947   }
2948
2949   if ($self->{id}) {
2950     $query =
2951       qq|SELECT
2952            a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2953            a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2954            a.intnotes, a.department_id, a.amount AS oldinvtotal,
2955            a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2956            a.globalproject_id,
2957            c.name AS $table,
2958            d.description AS department,
2959            e.name AS employee
2960          FROM $arap a
2961          JOIN $table c ON (a.${table}_id = c.id)
2962          LEFT JOIN employee e ON (e.id = a.employee_id)
2963          LEFT JOIN department d ON (d.id = a.department_id)
2964          WHERE a.id = ?|;
2965     $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2966
2967     foreach my $key (keys %$ref) {
2968       $self->{$key} = $ref->{$key};
2969     }
2970
2971     # remove any trailing whitespace
2972     $self->{currency} =~ s/\s*$//;
2973
2974     my $transdate = "current_date";
2975     if ($self->{transdate}) {
2976       $transdate = $dbh->quote($self->{transdate});
2977     }
2978
2979     # now get the account numbers
2980     $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2981                 FROM chart c
2982                 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2983                 WHERE c.link LIKE ?
2984                   AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2985                     OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2986                 ORDER BY c.accno|;
2987
2988     $sth = $dbh->prepare($query);
2989     do_statement($self, $sth, $query, "%$module%");
2990
2991     $self->{accounts} = "";
2992     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2993
2994       foreach my $key (split(/:/, $ref->{link})) {
2995         if ($key =~ /\Q$module\E/) {
2996
2997           # cross reference for keys
2998           $xkeyref{ $ref->{accno} } = $key;
2999
3000           push @{ $self->{"${module}_links"}{$key} },
3001             { accno       => $ref->{accno},
3002               description => $ref->{description},
3003               taxkey      => $ref->{taxkey_id},
3004               tax_id      => $ref->{tax_id} };
3005
3006           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
3007         }
3008       }
3009     }
3010
3011
3012     # get amounts from individual entries
3013     $query =
3014       qq|SELECT
3015            c.accno, c.description,
3016            a.acc_trans_id, a.source, a.amount, a.memo, a.transdate, a.gldate, a.cleared, a.project_id, a.taxkey,
3017            p.projectnumber,
3018            t.rate, t.id
3019          FROM acc_trans a
3020          LEFT JOIN chart c ON (c.id = a.chart_id)
3021          LEFT JOIN project p ON (p.id = a.project_id)
3022          LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
3023                                     WHERE (tk.taxkey_id=a.taxkey) AND
3024                                       ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
3025                                         THEN tk.chart_id = a.chart_id
3026                                         ELSE 1 = 1
3027                                         END)
3028                                        OR (c.link='%tax%')) AND
3029                                       (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
3030          WHERE a.trans_id = ?
3031          AND a.fx_transaction = '0'
3032          ORDER BY a.acc_trans_id, a.transdate|;
3033     $sth = $dbh->prepare($query);
3034     do_statement($self, $sth, $query, $self->{id});
3035
3036     # get exchangerate for currency
3037     $self->{exchangerate} =
3038       $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3039     my $index = 0;
3040
3041     # store amounts in {acc_trans}{$key} for multiple accounts
3042     while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
3043       $ref->{exchangerate} =
3044         $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
3045       if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
3046         $index++;
3047       }
3048       if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
3049         $ref->{amount} *= -1;
3050       }
3051       $ref->{index} = $index;
3052
3053       push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
3054     }
3055
3056     $sth->finish;
3057     $query =
3058       qq|SELECT
3059            d.curr AS currencies, d.closedto, d.revtrans,
3060            (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
3061            (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
3062          FROM defaults d|;
3063     $ref = selectfirst_hashref_query($self, $dbh, $query);
3064     map { $self->{$_} = $ref->{$_} } keys %$ref;
3065
3066   } else {
3067
3068     # get date
3069     $query =
3070        qq|SELECT
3071             current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
3072             (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
3073             (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
3074           FROM defaults d|;
3075     $ref = selectfirst_hashref_query($self, $dbh, $query);
3076     map { $self->{$_} = $ref->{$_} } keys %$ref;
3077
3078     if ($self->{"$self->{vc}_id"}) {
3079
3080       # only setup currency
3081       ($self->{currency}) = split(/:/, $self->{currencies});
3082
3083     } else {
3084
3085       $self->lastname_used($dbh, $myconfig, $table, $module);
3086
3087       # get exchangerate for currency
3088       $self->{exchangerate} =
3089         $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3090
3091     }
3092
3093   }
3094
3095   $main::lxdebug->leave_sub();
3096 }
3097
3098 sub lastname_used {
3099   $main::lxdebug->enter_sub();
3100
3101   my ($self, $dbh, $myconfig, $table, $module) = @_;
3102
3103   my ($arap, $where);
3104
3105   $table         = $table eq "customer" ? "customer" : "vendor";
3106   my %column_map = ("a.curr"                  => "currency",
3107                     "a.${table}_id"           => "${table}_id",
3108                     "a.department_id"         => "department_id",
3109                     "d.description"           => "department",
3110                     "ct.name"                 => $table,
3111                     "current_date + ct.terms" => "duedate",
3112     );
3113
3114   if ($self->{type} =~ /delivery_order/) {
3115     $arap  = 'delivery_orders';
3116     delete $column_map{"a.curr"};
3117
3118   } elsif ($self->{type} =~ /_order/) {
3119     $arap  = 'oe';
3120     $where = "quotation = '0'";
3121
3122   } elsif ($self->{type} =~ /_quotation/) {
3123     $arap  = 'oe';
3124     $where = "quotation = '1'";
3125
3126   } elsif ($table eq 'customer') {
3127     $arap  = 'ar';
3128
3129   } else {
3130     $arap  = 'ap';
3131
3132   }
3133
3134   $where           = "($where) AND" if ($where);
3135   my $query        = qq|SELECT MAX(id) FROM $arap
3136                         WHERE $where ${table}_id > 0|;
3137   my ($trans_id)   = selectrow_query($self, $dbh, $query);
3138   $trans_id       *= 1;
3139
3140   my $column_spec  = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3141   $query           = qq|SELECT $column_spec
3142                         FROM $arap a
3143                         LEFT JOIN $table     ct ON (a.${table}_id = ct.id)
3144                         LEFT JOIN department d  ON (a.department_id = d.id)
3145                         WHERE a.id = ?|;
3146   my $ref          = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3147
3148   map { $self->{$_} = $ref->{$_} } values %column_map;
3149
3150   # remove any trailing whitespace
3151   $self->{currency} =~ s/\s*$// if $self->{currency};
3152
3153   $main::lxdebug->leave_sub();
3154 }
3155
3156 sub current_date {
3157   $main::lxdebug->enter_sub();
3158
3159   my $self     = shift;
3160   my $myconfig = shift || \%::myconfig;
3161   my ($thisdate, $days) = @_;
3162
3163   my $dbh = $self->get_standard_dbh($myconfig);
3164   my $query;
3165
3166   $days *= 1;
3167   if ($thisdate) {
3168     my $dateformat = $myconfig->{dateformat};
3169     $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3170     $thisdate = $dbh->quote($thisdate);
3171     $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3172   } else {
3173     $query = qq|SELECT current_date AS thisdate|;
3174   }
3175
3176   ($thisdate) = selectrow_query($self, $dbh, $query);
3177
3178   $main::lxdebug->leave_sub();
3179
3180   return $thisdate;
3181 }
3182
3183 sub like {
3184   $main::lxdebug->enter_sub();
3185
3186   my ($self, $string) = @_;
3187
3188   if ($string !~ /%/) {
3189     $string = "%$string%";
3190   }
3191
3192   $string =~ s/\'/\'\'/g;
3193
3194   $main::lxdebug->leave_sub();
3195
3196   return $string;
3197 }
3198
3199 sub redo_rows {
3200   $main::lxdebug->enter_sub();
3201
3202   my ($self, $flds, $new, $count, $numrows) = @_;
3203
3204   my @ndx = ();
3205
3206   map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3207
3208   my $i = 0;
3209
3210   # fill rows
3211   foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3212     $i++;
3213     my $j = $item->{ndx} - 1;
3214     map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3215   }
3216
3217   # delete empty rows
3218   for $i ($count + 1 .. $numrows) {
3219     map { delete $self->{"${_}_$i"} } @{$flds};
3220   }
3221
3222   $main::lxdebug->leave_sub();
3223 }
3224
3225 sub update_status {
3226   $main::lxdebug->enter_sub();
3227
3228   my ($self, $myconfig) = @_;
3229
3230   my ($i, $id);
3231
3232   my $dbh = $self->dbconnect_noauto($myconfig);
3233
3234   my $query = qq|DELETE FROM status
3235                  WHERE (formname = ?) AND (trans_id = ?)|;
3236   my $sth = prepare_query($self, $dbh, $query);
3237
3238   if ($self->{formname} =~ /(check|receipt)/) {
3239     for $i (1 .. $self->{rowcount}) {
3240       do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3241     }
3242   } else {
3243     do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3244   }
3245   $sth->finish();
3246
3247   my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3248   my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3249
3250   my %queued = split / /, $self->{queued};
3251   my @values;
3252
3253   if ($self->{formname} =~ /(check|receipt)/) {
3254
3255     # this is a check or receipt, add one entry for each lineitem
3256     my ($accno) = split /--/, $self->{account};
3257     $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3258                 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3259     @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3260     $sth = prepare_query($self, $dbh, $query);
3261
3262     for $i (1 .. $self->{rowcount}) {
3263       if ($self->{"checked_$i"}) {
3264         do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3265       }
3266     }
3267     $sth->finish();
3268
3269   } else {
3270     $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3271                 VALUES (?, ?, ?, ?, ?)|;
3272     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3273              $queued{$self->{formname}}, $self->{formname});
3274   }
3275
3276   $dbh->commit;
3277   $dbh->disconnect;
3278
3279   $main::lxdebug->leave_sub();
3280 }
3281
3282 sub save_status {
3283   $main::lxdebug->enter_sub();
3284
3285   my ($self, $dbh) = @_;
3286
3287   my ($query, $printed, $emailed);
3288
3289   my $formnames  = $self->{printed};
3290   my $emailforms = $self->{emailed};
3291
3292   $query = qq|DELETE FROM status
3293                  WHERE (formname = ?) AND (trans_id = ?)|;
3294   do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3295
3296   # this only applies to the forms
3297   # checks and receipts are posted when printed or queued
3298
3299   if ($self->{queued}) {
3300     my %queued = split / /, $self->{queued};
3301
3302     foreach my $formname (keys %queued) {
3303       $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3304       $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3305
3306       $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3307                   VALUES (?, ?, ?, ?, ?)|;
3308       do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3309
3310       $formnames  =~ s/\Q$self->{formname}\E//;
3311       $emailforms =~ s/\Q$self->{formname}\E//;
3312
3313     }
3314   }
3315
3316   # save printed, emailed info
3317   $formnames  =~ s/^ +//g;
3318   $emailforms =~ s/^ +//g;
3319
3320   my %status = ();
3321   map { $status{$_}{printed} = 1 } split / +/, $formnames;
3322   map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3323
3324   foreach my $formname (keys %status) {
3325     $printed = ($formnames  =~ /\Q$self->{formname}\E/) ? "1" : "0";
3326     $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3327
3328     $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3329                 VALUES (?, ?, ?, ?)|;
3330     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3331   }
3332
3333   $main::lxdebug->leave_sub();
3334 }
3335
3336 #--- 4 locale ---#
3337 # $main::locale->text('SAVED')
3338 # $main::locale->text('DELETED')
3339 # $main::locale->text('ADDED')
3340 # $main::locale->text('PAYMENT POSTED')
3341 # $main::locale->text('POSTED')
3342 # $main::locale->text('POSTED AS NEW')
3343 # $main::locale->text('ELSE')
3344 # $main::locale->text('SAVED FOR DUNNING')
3345 # $main::locale->text('DUNNING STARTED')
3346 # $main::locale->text('PRINTED')
3347 # $main::locale->text('MAILED')
3348 # $main::locale->text('SCREENED')
3349 # $main::locale->text('CANCELED')
3350 # $main::locale->text('invoice')
3351 # $main::locale->text('proforma')
3352 # $main::locale->text('sales_order')
3353 # $main::locale->text('pick_list')
3354 # $main::locale->text('purchase_order')
3355 # $main::locale->text('bin_list')
3356 # $main::locale->text('sales_quotation')
3357 # $main::locale->text('request_quotation')
3358
3359 sub save_history {
3360   $main::lxdebug->enter_sub();
3361
3362   my $self = shift;
3363   my $dbh  = shift || $self->get_standard_dbh;
3364
3365   if(!exists $self->{employee_id}) {
3366     &get_employee($self, $dbh);
3367   }
3368
3369   my $query =
3370    qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3371    qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3372   my @values = (conv_i($self->{id}), $self->{login},
3373                 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3374   do_query($self, $dbh, $query, @values);
3375
3376   $dbh->commit;
3377
3378   $main::lxdebug->leave_sub();
3379 }
3380
3381 sub get_history {
3382   $main::lxdebug->enter_sub();
3383
3384   my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3385   my ($orderBy, $desc) = split(/\-\-/, $order);
3386   $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3387   my @tempArray;
3388   my $i = 0;
3389   if ($trans_id ne "") {
3390     my $query =
3391       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 | .
3392       qq|FROM history_erp h | .
3393       qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3394       qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3395       $order;
3396
3397     my $sth = $dbh->prepare($query) || $self->dberror($query);
3398
3399     $sth->execute() || $self->dberror("$query");
3400
3401     while(my $hash_ref = $sth->fetchrow_hashref()) {
3402       $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3403       $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3404       $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3405       $tempArray[$i++] = $hash_ref;
3406     }
3407     $main::lxdebug->leave_sub() and return \@tempArray
3408       if ($i > 0 && $tempArray[0] ne "");
3409   }
3410   $main::lxdebug->leave_sub();
3411   return 0;
3412 }
3413
3414 sub update_defaults {
3415   $main::lxdebug->enter_sub();
3416
3417   my ($self, $myconfig, $fld, $provided_dbh) = @_;
3418
3419   my $dbh;
3420   if ($provided_dbh) {
3421     $dbh = $provided_dbh;
3422   } else {
3423     $dbh = $self->dbconnect_noauto($myconfig);
3424   }
3425   my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3426   my $sth   = $dbh->prepare($query);
3427
3428   $sth->execute || $self->dberror($query);
3429   my ($var) = $sth->fetchrow_array;
3430   $sth->finish;
3431
3432   if ($var =~ m/\d+$/) {
3433     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3434     my $len_diff = length($var) - $-[0] - length($new_var);
3435     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3436
3437   } else {
3438     $var = $var . '1';
3439   }
3440
3441   $query = qq|UPDATE defaults SET $fld = ?|;
3442   do_query($self, $dbh, $query, $var);
3443
3444   if (!$provided_dbh) {
3445     $dbh->commit;
3446     $dbh->disconnect;
3447   }
3448
3449   $main::lxdebug->leave_sub();
3450
3451   return $var;
3452 }
3453
3454 sub update_business {
3455   $main::lxdebug->enter_sub();
3456
3457   my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3458
3459   my $dbh;
3460   if ($provided_dbh) {
3461     $dbh = $provided_dbh;
3462   } else {
3463     $dbh = $self->dbconnect_noauto($myconfig);
3464   }
3465   my $query =
3466     qq|SELECT customernumberinit FROM business
3467        WHERE id = ? FOR UPDATE|;
3468   my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3469
3470   return undef unless $var;
3471
3472   if ($var =~ m/\d+$/) {
3473     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3474     my $len_diff = length($var) - $-[0] - length($new_var);
3475     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3476
3477   } else {
3478     $var = $var . '1';
3479   }
3480
3481   $query = qq|UPDATE business
3482               SET customernumberinit = ?
3483               WHERE id = ?|;
3484   do_query($self, $dbh, $query, $var, $business_id);
3485
3486   if (!$provided_dbh) {
3487     $dbh->commit;
3488     $dbh->disconnect;
3489   }
3490
3491   $main::lxdebug->leave_sub();
3492
3493   return $var;
3494 }
3495
3496 sub get_partsgroup {
3497   $main::lxdebug->enter_sub();
3498
3499   my ($self, $myconfig, $p) = @_;
3500   my $target = $p->{target} || 'all_partsgroup';
3501
3502   my $dbh = $self->get_standard_dbh($myconfig);
3503
3504   my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3505                  FROM partsgroup pg
3506                  JOIN parts p ON (p.partsgroup_id = pg.id) |;
3507   my @values;
3508
3509   if ($p->{searchitems} eq 'part') {
3510     $query .= qq|WHERE p.inventory_accno_id > 0|;
3511   }
3512   if ($p->{searchitems} eq 'service') {
3513     $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3514   }
3515   if ($p->{searchitems} eq 'assembly') {
3516     $query .= qq|WHERE p.assembly = '1'|;
3517   }
3518   if ($p->{searchitems} eq 'labor') {
3519     $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3520   }
3521
3522   $query .= qq|ORDER BY partsgroup|;
3523
3524   if ($p->{all}) {
3525     $query = qq|SELECT id, partsgroup FROM partsgroup
3526                 ORDER BY partsgroup|;
3527   }
3528
3529   if ($p->{language_code}) {
3530     $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3531                   t.description AS translation
3532                 FROM partsgroup pg
3533                 JOIN parts p ON (p.partsgroup_id = pg.id)
3534                 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3535                 ORDER BY translation|;
3536     @values = ($p->{language_code});
3537   }
3538
3539   $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3540
3541   $main::lxdebug->leave_sub();
3542 }
3543
3544 sub get_pricegroup {
3545   $main::lxdebug->enter_sub();
3546
3547   my ($self, $myconfig, $p) = @_;
3548
3549   my $dbh = $self->get_standard_dbh($myconfig);
3550
3551   my $query = qq|SELECT p.id, p.pricegroup
3552                  FROM pricegroup p|;
3553
3554   $query .= qq| ORDER BY pricegroup|;
3555
3556   if ($p->{all}) {
3557     $query = qq|SELECT id, pricegroup FROM pricegroup
3558                 ORDER BY pricegroup|;
3559   }
3560
3561   $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3562
3563   $main::lxdebug->leave_sub();
3564 }
3565
3566 sub all_years {
3567 # usage $form->all_years($myconfig, [$dbh])
3568 # return list of all years where bookings found
3569 # (@all_years)
3570
3571   $main::lxdebug->enter_sub();
3572
3573   my ($self, $myconfig, $dbh) = @_;
3574
3575   $dbh ||= $self->get_standard_dbh($myconfig);
3576
3577   # get years
3578   my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3579                    (SELECT MAX(transdate) FROM acc_trans)|;
3580   my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3581
3582   if ($myconfig->{dateformat} =~ /^yy/) {
3583     ($startdate) = split /\W/, $startdate;
3584     ($enddate) = split /\W/, $enddate;
3585   } else {
3586     (@_) = split /\W/, $startdate;
3587     $startdate = $_[2];
3588     (@_) = split /\W/, $enddate;
3589     $enddate = $_[2];
3590   }
3591
3592   my @all_years;
3593   $startdate = substr($startdate,0,4);
3594   $enddate = substr($enddate,0,4);
3595
3596   while ($enddate >= $startdate) {
3597     push @all_years, $enddate--;
3598   }
3599
3600   return @all_years;
3601
3602   $main::lxdebug->leave_sub();
3603 }
3604
3605 sub backup_vars {
3606   $main::lxdebug->enter_sub();
3607   my $self = shift;
3608   my @vars = @_;
3609
3610   map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3611
3612   $main::lxdebug->leave_sub();
3613 }
3614
3615 sub restore_vars {
3616   $main::lxdebug->enter_sub();
3617
3618   my $self = shift;
3619   my @vars = @_;
3620
3621   map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3622
3623   $main::lxdebug->leave_sub();
3624 }
3625
3626 sub prepare_for_printing {
3627   my ($self) = @_;
3628
3629   $self->{templates} ||= $::myconfig{templates};
3630   $self->{formname}  ||= $self->{type};
3631   $self->{media}     ||= 'email';
3632
3633   die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3634
3635   # set shipto from billto unless set
3636   my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3637   if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3638     $self->{shiptoname}   = $::myconfig{company};
3639     $self->{shiptostreet} = $::myconfig{address};
3640   }
3641
3642   my $language = $self->{language} ? '_' . $self->{language} : '';
3643
3644   my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3645   if ($self->{language_id}) {
3646     ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3647   } else {
3648     $output_dateformat   = $::myconfig{dateformat};
3649     $output_numberformat = $::myconfig{numberformat};
3650     $output_longdates    = 1;
3651   }
3652
3653   # Retrieve accounts for tax calculation.
3654   IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3655
3656   if ($self->{type} =~ /_delivery_order$/) {
3657     DO->order_details();
3658   } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3659     OE->order_details(\%::myconfig, $self);
3660   } else {
3661     IS->invoice_details(\%::myconfig, $self, $::locale);
3662   }
3663
3664   # Chose extension & set source file name
3665   my $extension = 'html';
3666   if ($self->{format} eq 'postscript') {
3667     $self->{postscript}   = 1;
3668     $extension            = 'tex';
3669   } elsif ($self->{"format"} =~ /pdf/) {
3670     $self->{pdf}          = 1;
3671     $extension            = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3672   } elsif ($self->{"format"} =~ /opendocument/) {
3673     $self->{opendocument} = 1;
3674     $extension            = 'odt';
3675   } elsif ($self->{"format"} =~ /excel/) {
3676     $self->{excel}        = 1;
3677     $extension            = 'xls';
3678   }
3679
3680   my $printer_code    = '_' . $self->{printer_code} if $self->{printer_code};
3681   my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3682   $self->{IN}         = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3683
3684   # Format dates.
3685   $self->format_dates($output_dateformat, $output_longdates,
3686                       qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3687                          transdate_oe deliverydate_oe employee_startdate employee_enddate),
3688                       grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3689
3690   $self->reformat_numbers($output_numberformat, 2,
3691                           qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3692                           grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3693
3694   $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3695
3696   my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3697
3698   if (scalar @{ $cvar_date_fields }) {
3699     $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3700   }
3701
3702   while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3703     $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3704   }
3705
3706   return $self;
3707 }
3708
3709 sub format_dates {
3710   my ($self, $dateformat, $longformat, @indices) = @_;
3711
3712   $dateformat ||= $::myconfig{dateformat};
3713
3714   foreach my $idx (@indices) {
3715     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3716       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3717         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3718       }
3719     }
3720
3721     next unless defined $self->{$idx};
3722
3723     if (!ref($self->{$idx})) {
3724       $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3725
3726     } elsif (ref($self->{$idx}) eq "ARRAY") {
3727       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3728         $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3729       }
3730     }
3731   }
3732 }
3733
3734 sub reformat_numbers {
3735   my ($self, $numberformat, $places, @indices) = @_;
3736
3737   return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3738
3739   foreach my $idx (@indices) {
3740     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3741       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3742         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3743       }
3744     }
3745
3746     next unless defined $self->{$idx};
3747
3748     if (!ref($self->{$idx})) {
3749       $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3750
3751     } elsif (ref($self->{$idx}) eq "ARRAY") {
3752       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3753         $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3754       }
3755     }
3756   }
3757
3758   my $saved_numberformat    = $::myconfig{numberformat};
3759   $::myconfig{numberformat} = $numberformat;
3760
3761   foreach my $idx (@indices) {
3762     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3763       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3764         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3765       }
3766     }
3767
3768     next unless defined $self->{$idx};
3769
3770     if (!ref($self->{$idx})) {
3771       $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3772
3773     } elsif (ref($self->{$idx}) eq "ARRAY") {
3774       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3775         $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3776       }
3777     }
3778   }
3779
3780   $::myconfig{numberformat} = $saved_numberformat;
3781 }
3782
3783 1;
3784
3785 __END__
3786
3787 =head1 NAME
3788
3789 SL::Form.pm - main data object.
3790
3791 =head1 SYNOPSIS
3792
3793 This is the main data object of Lx-Office.
3794 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3795 Points of interest for a beginner are:
3796
3797  - $form->error            - renders a generic error in html. accepts an error message
3798  - $form->get_standard_dbh - returns a database connection for the
3799
3800 =head1 SPECIAL FUNCTIONS
3801
3802 =head2 C<_store_value()>
3803
3804 parses a complex var name, and stores it in the form.
3805
3806 syntax:
3807   $form->_store_value($key, $value);
3808
3809 keys must start with a string, and can contain various tokens.
3810 supported key structures are:
3811
3812 1. simple access
3813   simple key strings work as expected
3814
3815   id => $form->{id}
3816
3817 2. hash access.
3818   separating two keys by a dot (.) will result in a hash lookup for the inner value
3819   this is similar to the behaviour of java and templating mechanisms.
3820
3821   filter.description => $form->{filter}->{description}
3822
3823 3. array+hashref access
3824
3825   adding brackets ([]) before the dot will cause the next hash to be put into an array.
3826   using [+] instead of [] will force a new array index. this is useful for recurring
3827   data structures like part lists. put a [+] into the first varname, and use [] on the
3828   following ones.
3829
3830   repeating these names in your template:
3831
3832     invoice.items[+].id
3833     invoice.items[].parts_id
3834
3835   will result in:
3836
3837     $form->{invoice}->{items}->[
3838       {
3839         id       => ...
3840         parts_id => ...
3841       },
3842       {
3843         id       => ...
3844         parts_id => ...
3845       }
3846       ...
3847     ]
3848
3849 4. arrays
3850
3851   using brackets at the end of a name will result in a pure array to be created.
3852   note that you mustn't use [+], which is reserved for array+hash access and will
3853   result in undefined behaviour in array context.
3854
3855   filter.status[]  => $form->{status}->[ val1, val2, ... ]
3856
3857 =head2 C<update_business> PARAMS
3858
3859 PARAMS (not named):
3860  \%config,     - config hashref
3861  $business_id, - business id
3862  $dbh          - optional database handle
3863
3864 handles business (thats customer/vendor types) sequences.
3865
3866 special behaviour for empty strings in customerinitnumber field:
3867 will in this case not increase the value, and return undef.
3868
3869 =head2 C<redirect_header> $url
3870
3871 Generates a HTTP redirection header for the new C<$url>. Constructs an
3872 absolute URL including scheme, host name and port. If C<$url> is a
3873 relative URL then it is considered relative to Lx-Office base URL.
3874
3875 This function C<die>s if headers have already been created with
3876 C<$::form-E<gt>header>.
3877
3878 Examples:
3879
3880   print $::form->redirect_header('oe.pl?action=edit&id=1234');
3881   print $::form->redirect_header('http://www.lx-office.org/');
3882
3883 =head2 C<header>
3884
3885 Generates a general purpose http/html header and includes most of the scripts
3886 and stylesheets needed. Stylesheets can be added with L<use_stylesheet>.
3887
3888 Only one header will be generated. If the method was already called in this
3889 request it will not output anything and return undef. Also if no
3890 HTTP_USER_AGENT is found, no header is generated.
3891
3892 Although header does not accept parameters itself, it will honor special
3893 hashkeys of its Form instance:
3894
3895 =over 4
3896
3897 =item refresh_time
3898
3899 =item refresh_url
3900
3901 If one of these is set, a http-equiv refresh is generated. Missing parameters
3902 default to 3 seconds and the refering url.
3903
3904 =item stylesheet
3905
3906 Either a scalar or an array ref. Will be inlined into the header. Add
3907 stylesheets with the L<use_stylesheet> function.
3908
3909 =item landscape
3910
3911 If true, a css snippet will be generated that sets the page in landscape mode.
3912
3913 =item favicon
3914
3915 Used to override the default favicon.
3916
3917 =item title
3918
3919 A html page title will be generated from this
3920
3921 =back
3922
3923 =cut