SL/Form.pm

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