SL/Form.pm

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