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