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