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