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