SL/Form.pm

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