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