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