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