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