SL/Form.pm

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