SL/Form.pm

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