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                 ORDER BY description|;
2466     my $sth = prepare_query($self, $dbh, $query);
2467
2468     foreach my $warehouse (@{ $self->{$key} }) {
2469       do_statement($self, $sth, $query, $warehouse->{id});
2470       $warehouse->{$bins_key} = [];
2471
2472       while (my $ref = $sth->fetchrow_hashref()) {
2473         push @{ $warehouse->{$bins_key} }, $ref;
2474       }
2475     }
2476     $sth->finish();
2477   }
2478
2479   $main::lxdebug->leave_sub();
2480 }
2481
2482 sub _get_simple {
2483   $main::lxdebug->enter_sub();
2484
2485   my ($self, $dbh, $table, $key, $sortkey) = @_;
2486
2487   my $query  = qq|SELECT * FROM $table|;
2488   $query    .= qq| ORDER BY $sortkey| if ($sortkey);
2489
2490   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2491
2492   $main::lxdebug->leave_sub();
2493 }
2494
2495 #sub _get_groups {
2496 #  $main::lxdebug->enter_sub();
2497 #
2498 #  my ($self, $dbh, $key) = @_;
2499 #
2500 #  $key ||= "all_groups";
2501 #
2502 #  my $groups = $main::auth->read_groups();
2503 #
2504 #  $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2505 #
2506 #  $main::lxdebug->leave_sub();
2507 #}
2508
2509 sub get_lists {
2510   $main::lxdebug->enter_sub();
2511
2512   my $self = shift;
2513   my %params = @_;
2514
2515   my $dbh = $self->get_standard_dbh(\%main::myconfig);
2516   my ($sth, $query, $ref);
2517
2518   my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2519   my $vc_id = $self->{"${vc}_id"};
2520
2521   if ($params{"contacts"}) {
2522     $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2523   }
2524
2525   if ($params{"shipto"}) {
2526     $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2527   }
2528
2529   if ($params{"projects"} || $params{"all_projects"}) {
2530     $self->_get_projects($dbh, $params{"all_projects"} ?
2531                          $params{"all_projects"} : $params{"projects"},
2532                          $params{"all_projects"} ? 1 : 0);
2533   }
2534
2535   if ($params{"printers"}) {
2536     $self->_get_printers($dbh, $params{"printers"});
2537   }
2538
2539   if ($params{"languages"}) {
2540     $self->_get_languages($dbh, $params{"languages"});
2541   }
2542
2543   if ($params{"charts"}) {
2544     $self->_get_charts($dbh, $params{"charts"});
2545   }
2546
2547   if ($params{"taxcharts"}) {
2548     $self->_get_taxcharts($dbh, $params{"taxcharts"});
2549   }
2550
2551   if ($params{"taxzones"}) {
2552     $self->_get_taxzones($dbh, $params{"taxzones"});
2553   }
2554
2555   if ($params{"employees"}) {
2556     $self->_get_employees($dbh, "all_employees", $params{"employees"});
2557   }
2558
2559   if ($params{"salesmen"}) {
2560     $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2561   }
2562
2563   if ($params{"business_types"}) {
2564     $self->_get_business_types($dbh, $params{"business_types"});
2565   }
2566
2567   if ($params{"dunning_configs"}) {
2568     $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2569   }
2570
2571   if($params{"currencies"}) {
2572     $self->_get_currencies($dbh, $params{"currencies"});
2573   }
2574
2575   if($params{"customers"}) {
2576     $self->_get_customers($dbh, $params{"customers"});
2577   }
2578
2579   if($params{"vendors"}) {
2580     if (ref $params{"vendors"} eq 'HASH') {
2581       $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2582     } else {
2583       $self->_get_vendors($dbh, $params{"vendors"});
2584     }
2585   }
2586
2587   if($params{"payments"}) {
2588     $self->_get_payments($dbh, $params{"payments"});
2589   }
2590
2591   if($params{"departments"}) {
2592     $self->_get_departments($dbh, $params{"departments"});
2593   }
2594
2595   if ($params{price_factors}) {
2596     $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2597   }
2598
2599   if ($params{warehouses}) {
2600     $self->_get_warehouses($dbh, $params{warehouses});
2601   }
2602
2603 #  if ($params{groups}) {
2604 #    $self->_get_groups($dbh, $params{groups});
2605 #  }
2606
2607   if ($params{partsgroup}) {
2608     $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2609   }
2610
2611   $main::lxdebug->leave_sub();
2612 }
2613
2614 # this sub gets the id and name from $table
2615 sub get_name {
2616   $main::lxdebug->enter_sub();
2617
2618   my ($self, $myconfig, $table) = @_;
2619
2620   # connect to database
2621   my $dbh = $self->get_standard_dbh($myconfig);
2622
2623   $table = $table eq "customer" ? "customer" : "vendor";
2624   my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2625
2626   my ($query, @values);
2627
2628   if (!$self->{openinvoices}) {
2629     my $where;
2630     if ($self->{customernumber} ne "") {
2631       $where = qq|(vc.customernumber ILIKE ?)|;
2632       push(@values, '%' . $self->{customernumber} . '%');
2633     } else {
2634       $where = qq|(vc.name ILIKE ?)|;
2635       push(@values, '%' . $self->{$table} . '%');
2636     }
2637
2638     $query =
2639       qq~SELECT vc.id, vc.name,
2640            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2641          FROM $table vc
2642          WHERE $where AND (NOT vc.obsolete)
2643          ORDER BY vc.name~;
2644   } else {
2645     $query =
2646       qq~SELECT DISTINCT vc.id, vc.name,
2647            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2648          FROM $arap a
2649          JOIN $table vc ON (a.${table}_id = vc.id)
2650          WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2651          ORDER BY vc.name~;
2652     push(@values, '%' . $self->{$table} . '%');
2653   }
2654
2655   $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2656
2657   $main::lxdebug->leave_sub();
2658
2659   return scalar(@{ $self->{name_list} });
2660 }
2661
2662 # the selection sub is used in the AR, AP, IS, IR and OE module
2663 #
2664 sub all_vc {
2665   $main::lxdebug->enter_sub();
2666
2667   my ($self, $myconfig, $table, $module) = @_;
2668
2669   my $ref;
2670   my $dbh = $self->get_standard_dbh;
2671
2672   $table = $table eq "customer" ? "customer" : "vendor";
2673
2674   my $query = qq|SELECT count(*) FROM $table|;
2675   my ($count) = selectrow_query($self, $dbh, $query);
2676
2677   # build selection list
2678   if ($count <= $myconfig->{vclimit}) {
2679     $query = qq|SELECT id, name, salesman_id
2680                 FROM $table WHERE NOT obsolete
2681                 ORDER BY name|;
2682     $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2683   }
2684
2685   # get self
2686   $self->get_employee($dbh);
2687
2688   # setup sales contacts
2689   $query = qq|SELECT e.id, e.name
2690               FROM employee e
2691               WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2692   $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2693
2694   # this is for self
2695   push(@{ $self->{all_employees} },
2696        { id   => $self->{employee_id},
2697          name => $self->{employee} });
2698
2699   # sort the whole thing
2700   @{ $self->{all_employees} } =
2701     sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2702
2703   if ($module eq 'AR') {
2704
2705     # prepare query for departments
2706     $query = qq|SELECT id, description
2707                 FROM department
2708                 WHERE role = 'P'
2709                 ORDER BY description|;
2710
2711   } else {
2712     $query = qq|SELECT id, description
2713                 FROM department
2714                 ORDER BY description|;
2715   }
2716
2717   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2718
2719   # get languages
2720   $query = qq|SELECT id, description
2721               FROM language
2722               ORDER BY id|;
2723
2724   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2725
2726   # get printer
2727   $query = qq|SELECT printer_description, id
2728               FROM printers
2729               ORDER BY printer_description|;
2730
2731   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2732
2733   # get payment terms
2734   $query = qq|SELECT id, description
2735               FROM payment_terms
2736               ORDER BY sortkey|;
2737
2738   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2739
2740   $main::lxdebug->leave_sub();
2741 }
2742
2743 sub language_payment {
2744   $main::lxdebug->enter_sub();
2745
2746   my ($self, $myconfig) = @_;
2747
2748   my $dbh = $self->get_standard_dbh($myconfig);
2749   # get languages
2750   my $query = qq|SELECT id, description
2751                  FROM language
2752                  ORDER BY id|;
2753
2754   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2755
2756   # get printer
2757   $query = qq|SELECT printer_description, id
2758               FROM printers
2759               ORDER BY printer_description|;
2760
2761   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2762
2763   # get payment terms
2764   $query = qq|SELECT id, description
2765               FROM payment_terms
2766               ORDER BY sortkey|;
2767
2768   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2769
2770   # get buchungsgruppen
2771   $query = qq|SELECT id, description
2772               FROM buchungsgruppen|;
2773
2774   $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2775
2776   $main::lxdebug->leave_sub();
2777 }
2778
2779 # this is only used for reports
2780 sub all_departments {
2781   $main::lxdebug->enter_sub();
2782
2783   my ($self, $myconfig, $table) = @_;
2784
2785   my $dbh = $self->get_standard_dbh($myconfig);
2786   my $where;
2787
2788   if ($table eq 'customer') {
2789     $where = "WHERE role = 'P' ";
2790   }
2791
2792   my $query = qq|SELECT id, description
2793                  FROM department
2794                  $where
2795                  ORDER BY description|;
2796   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2797
2798   delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2799
2800   $main::lxdebug->leave_sub();
2801 }
2802
2803 sub create_links {
2804   $main::lxdebug->enter_sub();
2805
2806   my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2807
2808   my ($fld, $arap);
2809   if ($table eq "customer") {
2810     $fld = "buy";
2811     $arap = "ar";
2812   } else {
2813     $table = "vendor";
2814     $fld = "sell";
2815     $arap = "ap";
2816   }
2817
2818   $self->all_vc($myconfig, $table, $module);
2819
2820   # get last customers or vendors
2821   my ($query, $sth, $ref);
2822
2823   my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2824   my %xkeyref = ();
2825
2826   if (!$self->{id}) {
2827
2828     my $transdate = "current_date";
2829     if ($self->{transdate}) {
2830       $transdate = $dbh->quote($self->{transdate});
2831     }
2832
2833     # now get the account numbers
2834     $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2835                 FROM chart c, taxkeys tk
2836                 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2837                   (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2838                 ORDER BY c.accno|;
2839
2840     $sth = $dbh->prepare($query);
2841
2842     do_statement($self, $sth, $query, '%' . $module . '%');
2843
2844     $self->{accounts} = "";
2845     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2846
2847       foreach my $key (split(/:/, $ref->{link})) {
2848         if ($key =~ /\Q$module\E/) {
2849
2850           # cross reference for keys
2851           $xkeyref{ $ref->{accno} } = $key;
2852
2853           push @{ $self->{"${module}_links"}{$key} },
2854             { accno       => $ref->{accno},
2855               description => $ref->{description},
2856               taxkey      => $ref->{taxkey_id},
2857               tax_id      => $ref->{tax_id} };
2858
2859           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2860         }
2861       }
2862     }
2863   }
2864
2865   # get taxkeys and description
2866   $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2867   $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2868
2869   if (($module eq "AP") || ($module eq "AR")) {
2870     # get tax rates and description
2871     $query = qq|SELECT * FROM tax|;
2872     $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2873   }
2874
2875   if ($self->{id}) {
2876     $query =
2877       qq|SELECT
2878            a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2879            a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2880            a.intnotes, a.department_id, a.amount AS oldinvtotal,
2881            a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2882            c.name AS $table,
2883            d.description AS department,
2884            e.name AS employee
2885          FROM $arap a
2886          JOIN $table c ON (a.${table}_id = c.id)
2887          LEFT JOIN employee e ON (e.id = a.employee_id)
2888          LEFT JOIN department d ON (d.id = a.department_id)
2889          WHERE a.id = ?|;
2890     $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2891
2892     foreach my $key (keys %$ref) {
2893       $self->{$key} = $ref->{$key};
2894     }
2895
2896     my $transdate = "current_date";
2897     if ($self->{transdate}) {
2898       $transdate = $dbh->quote($self->{transdate});
2899     }
2900
2901     # now get the account numbers
2902     $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2903                 FROM chart c
2904                 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2905                 WHERE c.link LIKE ?
2906                   AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2907                     OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2908                 ORDER BY c.accno|;
2909
2910     $sth = $dbh->prepare($query);
2911     do_statement($self, $sth, $query, "%$module%");
2912
2913     $self->{accounts} = "";
2914     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2915
2916       foreach my $key (split(/:/, $ref->{link})) {
2917         if ($key =~ /\Q$module\E/) {
2918
2919           # cross reference for keys
2920           $xkeyref{ $ref->{accno} } = $key;
2921
2922           push @{ $self->{"${module}_links"}{$key} },
2923             { accno       => $ref->{accno},
2924               description => $ref->{description},
2925               taxkey      => $ref->{taxkey_id},
2926               tax_id      => $ref->{tax_id} };
2927
2928           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2929         }
2930       }
2931     }
2932
2933
2934     # get amounts from individual entries
2935     $query =
2936       qq|SELECT
2937            c.accno, c.description,
2938            a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2939            p.projectnumber,
2940            t.rate, t.id
2941          FROM acc_trans a
2942          LEFT JOIN chart c ON (c.id = a.chart_id)
2943          LEFT JOIN project p ON (p.id = a.project_id)
2944          LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2945                                     WHERE (tk.taxkey_id=a.taxkey) AND
2946                                       ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2947                                         THEN tk.chart_id = a.chart_id
2948                                         ELSE 1 = 1
2949                                         END)
2950                                        OR (c.link='%tax%')) AND
2951                                       (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2952          WHERE a.trans_id = ?
2953          AND a.fx_transaction = '0'
2954          ORDER BY a.acc_trans_id, a.transdate|;
2955     $sth = $dbh->prepare($query);
2956     do_statement($self, $sth, $query, $self->{id});
2957
2958     # get exchangerate for currency
2959     $self->{exchangerate} =
2960       $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2961     my $index = 0;
2962
2963     # store amounts in {acc_trans}{$key} for multiple accounts
2964     while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2965       $ref->{exchangerate} =
2966         $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2967       if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2968         $index++;
2969       }
2970       if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2971         $ref->{amount} *= -1;
2972       }
2973       $ref->{index} = $index;
2974
2975       push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2976     }
2977
2978     $sth->finish;
2979     $query =
2980       qq|SELECT
2981            d.curr AS currencies, d.closedto, d.revtrans,
2982            (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2983            (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2984          FROM defaults d|;
2985     $ref = selectfirst_hashref_query($self, $dbh, $query);
2986     map { $self->{$_} = $ref->{$_} } keys %$ref;
2987
2988   } else {
2989
2990     # get date
2991     $query =
2992        qq|SELECT
2993             current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2994             (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2995             (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2996           FROM defaults d|;
2997     $ref = selectfirst_hashref_query($self, $dbh, $query);
2998     map { $self->{$_} = $ref->{$_} } keys %$ref;
2999
3000     if ($self->{"$self->{vc}_id"}) {
3001
3002       # only setup currency
3003       ($self->{currency}) = split(/:/, $self->{currencies});
3004
3005     } else {
3006
3007       $self->lastname_used($dbh, $myconfig, $table, $module);
3008
3009       # get exchangerate for currency
3010       $self->{exchangerate} =
3011         $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3012
3013     }
3014
3015   }
3016
3017   $main::lxdebug->leave_sub();
3018 }
3019
3020 sub lastname_used {
3021   $main::lxdebug->enter_sub();
3022
3023   my ($self, $dbh, $myconfig, $table, $module) = @_;
3024
3025   my ($arap, $where);
3026
3027   $table         = $table eq "customer" ? "customer" : "vendor";
3028   my %column_map = ("a.curr"                  => "currency",
3029                     "a.${table}_id"           => "${table}_id",
3030                     "a.department_id"         => "department_id",
3031                     "d.description"           => "department",
3032                     "ct.name"                 => $table,
3033                     "current_date + ct.terms" => "duedate",
3034     );
3035
3036   if ($self->{type} =~ /delivery_order/) {
3037     $arap  = 'delivery_orders';
3038     delete $column_map{"a.curr"};
3039
3040   } elsif ($self->{type} =~ /_order/) {
3041     $arap  = 'oe';
3042     $where = "quotation = '0'";
3043
3044   } elsif ($self->{type} =~ /_quotation/) {
3045     $arap  = 'oe';
3046     $where = "quotation = '1'";
3047
3048   } elsif ($table eq 'customer') {
3049     $arap  = 'ar';
3050
3051   } else {
3052     $arap  = 'ap';
3053
3054   }
3055
3056   $where           = "($where) AND" if ($where);
3057   my $query        = qq|SELECT MAX(id) FROM $arap
3058                         WHERE $where ${table}_id > 0|;
3059   my ($trans_id)   = selectrow_query($self, $dbh, $query);
3060   $trans_id       *= 1;
3061
3062   my $column_spec  = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3063   $query           = qq|SELECT $column_spec
3064                         FROM $arap a
3065                         LEFT JOIN $table     ct ON (a.${table}_id = ct.id)
3066                         LEFT JOIN department d  ON (a.department_id = d.id)
3067                         WHERE a.id = ?|;
3068   my $ref          = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3069
3070   map { $self->{$_} = $ref->{$_} } values %column_map;
3071
3072   $main::lxdebug->leave_sub();
3073 }
3074
3075 sub current_date {
3076   $main::lxdebug->enter_sub();
3077
3078   my $self     = shift;
3079   my $myconfig = shift || \%::myconfig;
3080   my ($thisdate, $days) = @_;
3081
3082   my $dbh = $self->get_standard_dbh($myconfig);
3083   my $query;
3084
3085   $days *= 1;
3086   if ($thisdate) {
3087     my $dateformat = $myconfig->{dateformat};
3088     $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3089     $thisdate = $dbh->quote($thisdate);
3090     $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3091   } else {
3092     $query = qq|SELECT current_date AS thisdate|;
3093   }
3094
3095   ($thisdate) = selectrow_query($self, $dbh, $query);
3096
3097   $main::lxdebug->leave_sub();
3098
3099   return $thisdate;
3100 }
3101
3102 sub like {
3103   $main::lxdebug->enter_sub();
3104
3105   my ($self, $string) = @_;
3106
3107   if ($string !~ /%/) {
3108     $string = "%$string%";
3109   }
3110
3111   $string =~ s/\'/\'\'/g;
3112
3113   $main::lxdebug->leave_sub();
3114
3115   return $string;
3116 }
3117
3118 sub redo_rows {
3119   $main::lxdebug->enter_sub();
3120
3121   my ($self, $flds, $new, $count, $numrows) = @_;
3122
3123   my @ndx = ();
3124
3125   map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3126
3127   my $i = 0;
3128
3129   # fill rows
3130   foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3131     $i++;
3132     my $j = $item->{ndx} - 1;
3133     map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3134   }
3135
3136   # delete empty rows
3137   for $i ($count + 1 .. $numrows) {
3138     map { delete $self->{"${_}_$i"} } @{$flds};
3139   }
3140
3141   $main::lxdebug->leave_sub();
3142 }
3143
3144 sub update_status {
3145   $main::lxdebug->enter_sub();
3146
3147   my ($self, $myconfig) = @_;
3148
3149   my ($i, $id);
3150
3151   my $dbh = $self->dbconnect_noauto($myconfig);
3152
3153   my $query = qq|DELETE FROM status
3154                  WHERE (formname = ?) AND (trans_id = ?)|;
3155   my $sth = prepare_query($self, $dbh, $query);
3156
3157   if ($self->{formname} =~ /(check|receipt)/) {
3158     for $i (1 .. $self->{rowcount}) {
3159       do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3160     }
3161   } else {
3162     do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3163   }
3164   $sth->finish();
3165
3166   my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3167   my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3168
3169   my %queued = split / /, $self->{queued};
3170   my @values;
3171
3172   if ($self->{formname} =~ /(check|receipt)/) {
3173
3174     # this is a check or receipt, add one entry for each lineitem
3175     my ($accno) = split /--/, $self->{account};
3176     $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3177                 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3178     @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3179     $sth = prepare_query($self, $dbh, $query);
3180
3181     for $i (1 .. $self->{rowcount}) {
3182       if ($self->{"checked_$i"}) {
3183         do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3184       }
3185     }
3186     $sth->finish();
3187
3188   } else {
3189     $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3190                 VALUES (?, ?, ?, ?, ?)|;
3191     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3192              $queued{$self->{formname}}, $self->{formname});
3193   }
3194
3195   $dbh->commit;
3196   $dbh->disconnect;
3197
3198   $main::lxdebug->leave_sub();
3199 }
3200
3201 sub save_status {
3202   $main::lxdebug->enter_sub();
3203
3204   my ($self, $dbh) = @_;
3205
3206   my ($query, $printed, $emailed);
3207
3208   my $formnames  = $self->{printed};
3209   my $emailforms = $self->{emailed};
3210
3211   $query = qq|DELETE FROM status
3212                  WHERE (formname = ?) AND (trans_id = ?)|;
3213   do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3214
3215   # this only applies to the forms
3216   # checks and receipts are posted when printed or queued
3217
3218   if ($self->{queued}) {
3219     my %queued = split / /, $self->{queued};
3220
3221     foreach my $formname (keys %queued) {
3222       $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3223       $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3224
3225       $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3226                   VALUES (?, ?, ?, ?, ?)|;
3227       do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3228
3229       $formnames  =~ s/\Q$self->{formname}\E//;
3230       $emailforms =~ s/\Q$self->{formname}\E//;
3231
3232     }
3233   }
3234
3235   # save printed, emailed info
3236   $formnames  =~ s/^ +//g;
3237   $emailforms =~ s/^ +//g;
3238
3239   my %status = ();
3240   map { $status{$_}{printed} = 1 } split / +/, $formnames;
3241   map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3242
3243   foreach my $formname (keys %status) {
3244     $printed = ($formnames  =~ /\Q$self->{formname}\E/) ? "1" : "0";
3245     $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3246
3247     $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3248                 VALUES (?, ?, ?, ?)|;
3249     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3250   }
3251
3252   $main::lxdebug->leave_sub();
3253 }
3254
3255 #--- 4 locale ---#
3256 # $main::locale->text('SAVED')
3257 # $main::locale->text('DELETED')
3258 # $main::locale->text('ADDED')
3259 # $main::locale->text('PAYMENT POSTED')
3260 # $main::locale->text('POSTED')
3261 # $main::locale->text('POSTED AS NEW')
3262 # $main::locale->text('ELSE')
3263 # $main::locale->text('SAVED FOR DUNNING')
3264 # $main::locale->text('DUNNING STARTED')
3265 # $main::locale->text('PRINTED')
3266 # $main::locale->text('MAILED')
3267 # $main::locale->text('SCREENED')
3268 # $main::locale->text('CANCELED')
3269 # $main::locale->text('invoice')
3270 # $main::locale->text('proforma')
3271 # $main::locale->text('sales_order')
3272 # $main::locale->text('pick_list')
3273 # $main::locale->text('purchase_order')
3274 # $main::locale->text('bin_list')
3275 # $main::locale->text('sales_quotation')
3276 # $main::locale->text('request_quotation')
3277
3278 sub save_history {
3279   $main::lxdebug->enter_sub();
3280
3281   my $self = shift;
3282   my $dbh  = shift || $self->get_standard_dbh;
3283
3284   if(!exists $self->{employee_id}) {
3285     &get_employee($self, $dbh);
3286   }
3287
3288   my $query =
3289    qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3290    qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3291   my @values = (conv_i($self->{id}), $self->{login},
3292                 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3293   do_query($self, $dbh, $query, @values);
3294
3295   $dbh->commit;
3296
3297   $main::lxdebug->leave_sub();
3298 }
3299
3300 sub get_history {
3301   $main::lxdebug->enter_sub();
3302
3303   my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3304   my ($orderBy, $desc) = split(/\-\-/, $order);
3305   $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3306   my @tempArray;
3307   my $i = 0;
3308   if ($trans_id ne "") {
3309     my $query =
3310       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 | .
3311       qq|FROM history_erp h | .
3312       qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3313       qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3314       $order;
3315
3316     my $sth = $dbh->prepare($query) || $self->dberror($query);
3317
3318     $sth->execute() || $self->dberror("$query");
3319
3320     while(my $hash_ref = $sth->fetchrow_hashref()) {
3321       $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3322       $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3323       $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3324       $tempArray[$i++] = $hash_ref;
3325     }
3326     $main::lxdebug->leave_sub() and return \@tempArray
3327       if ($i > 0 && $tempArray[0] ne "");
3328   }
3329   $main::lxdebug->leave_sub();
3330   return 0;
3331 }
3332
3333 sub update_defaults {
3334   $main::lxdebug->enter_sub();
3335
3336   my ($self, $myconfig, $fld, $provided_dbh) = @_;
3337
3338   my $dbh;
3339   if ($provided_dbh) {
3340     $dbh = $provided_dbh;
3341   } else {
3342     $dbh = $self->dbconnect_noauto($myconfig);
3343   }
3344   my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3345   my $sth   = $dbh->prepare($query);
3346
3347   $sth->execute || $self->dberror($query);
3348   my ($var) = $sth->fetchrow_array;
3349   $sth->finish;
3350
3351   if ($var =~ m/\d+$/) {
3352     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3353     my $len_diff = length($var) - $-[0] - length($new_var);
3354     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3355
3356   } else {
3357     $var = $var . '1';
3358   }
3359
3360   $query = qq|UPDATE defaults SET $fld = ?|;
3361   do_query($self, $dbh, $query, $var);
3362
3363   if (!$provided_dbh) {
3364     $dbh->commit;
3365     $dbh->disconnect;
3366   }
3367
3368   $main::lxdebug->leave_sub();
3369
3370   return $var;
3371 }
3372
3373 sub update_business {
3374   $main::lxdebug->enter_sub();
3375
3376   my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3377
3378   my $dbh;
3379   if ($provided_dbh) {
3380     $dbh = $provided_dbh;
3381   } else {
3382     $dbh = $self->dbconnect_noauto($myconfig);
3383   }
3384   my $query =
3385     qq|SELECT customernumberinit FROM business
3386        WHERE id = ? FOR UPDATE|;
3387   my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3388
3389   return undef unless $var;
3390
3391   if ($var =~ m/\d+$/) {
3392     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3393     my $len_diff = length($var) - $-[0] - length($new_var);
3394     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3395
3396   } else {
3397     $var = $var . '1';
3398   }
3399
3400   $query = qq|UPDATE business
3401               SET customernumberinit = ?
3402               WHERE id = ?|;
3403   do_query($self, $dbh, $query, $var, $business_id);
3404
3405   if (!$provided_dbh) {
3406     $dbh->commit;
3407     $dbh->disconnect;
3408   }
3409
3410   $main::lxdebug->leave_sub();
3411
3412   return $var;
3413 }
3414
3415 sub get_partsgroup {
3416   $main::lxdebug->enter_sub();
3417
3418   my ($self, $myconfig, $p) = @_;
3419   my $target = $p->{target} || 'all_partsgroup';
3420
3421   my $dbh = $self->get_standard_dbh($myconfig);
3422
3423   my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3424                  FROM partsgroup pg
3425                  JOIN parts p ON (p.partsgroup_id = pg.id) |;
3426   my @values;
3427
3428   if ($p->{searchitems} eq 'part') {
3429     $query .= qq|WHERE p.inventory_accno_id > 0|;
3430   }
3431   if ($p->{searchitems} eq 'service') {
3432     $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3433   }
3434   if ($p->{searchitems} eq 'assembly') {
3435     $query .= qq|WHERE p.assembly = '1'|;
3436   }
3437   if ($p->{searchitems} eq 'labor') {
3438     $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3439   }
3440
3441   $query .= qq|ORDER BY partsgroup|;
3442
3443   if ($p->{all}) {
3444     $query = qq|SELECT id, partsgroup FROM partsgroup
3445                 ORDER BY partsgroup|;
3446   }
3447
3448   if ($p->{language_code}) {
3449     $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3450                   t.description AS translation
3451                 FROM partsgroup pg
3452                 JOIN parts p ON (p.partsgroup_id = pg.id)
3453                 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3454                 ORDER BY translation|;
3455     @values = ($p->{language_code});
3456   }
3457
3458   $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3459
3460   $main::lxdebug->leave_sub();
3461 }
3462
3463 sub get_pricegroup {
3464   $main::lxdebug->enter_sub();
3465
3466   my ($self, $myconfig, $p) = @_;
3467
3468   my $dbh = $self->get_standard_dbh($myconfig);
3469
3470   my $query = qq|SELECT p.id, p.pricegroup
3471                  FROM pricegroup p|;
3472
3473   $query .= qq| ORDER BY pricegroup|;
3474
3475   if ($p->{all}) {
3476     $query = qq|SELECT id, pricegroup FROM pricegroup
3477                 ORDER BY pricegroup|;
3478   }
3479
3480   $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3481
3482   $main::lxdebug->leave_sub();
3483 }
3484
3485 sub all_years {
3486 # usage $form->all_years($myconfig, [$dbh])
3487 # return list of all years where bookings found
3488 # (@all_years)
3489
3490   $main::lxdebug->enter_sub();
3491
3492   my ($self, $myconfig, $dbh) = @_;
3493
3494   $dbh ||= $self->get_standard_dbh($myconfig);
3495
3496   # get years
3497   my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3498                    (SELECT MAX(transdate) FROM acc_trans)|;
3499   my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3500
3501   if ($myconfig->{dateformat} =~ /^yy/) {
3502     ($startdate) = split /\W/, $startdate;
3503     ($enddate) = split /\W/, $enddate;
3504   } else {
3505     (@_) = split /\W/, $startdate;
3506     $startdate = $_[2];
3507     (@_) = split /\W/, $enddate;
3508     $enddate = $_[2];
3509   }
3510
3511   my @all_years;
3512   $startdate = substr($startdate,0,4);
3513   $enddate = substr($enddate,0,4);
3514
3515   while ($enddate >= $startdate) {
3516     push @all_years, $enddate--;
3517   }
3518
3519   return @all_years;
3520
3521   $main::lxdebug->leave_sub();
3522 }
3523
3524 sub backup_vars {
3525   $main::lxdebug->enter_sub();
3526   my $self = shift;
3527   my @vars = @_;
3528
3529   map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3530
3531   $main::lxdebug->leave_sub();
3532 }
3533
3534 sub restore_vars {
3535   $main::lxdebug->enter_sub();
3536
3537   my $self = shift;
3538   my @vars = @_;
3539
3540   map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3541
3542   $main::lxdebug->leave_sub();
3543 }
3544
3545 sub prepare_for_printing {
3546   my ($self) = @_;
3547
3548   $self->{templates} ||= $::myconfig{templates};
3549   $self->{formname}  ||= $self->{type};
3550   $self->{media}     ||= 'email';
3551
3552   die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3553
3554   # set shipto from billto unless set
3555   my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3556   if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3557     $self->{shiptoname}   = $::myconfig{company};
3558     $self->{shiptostreet} = $::myconfig{address};
3559   }
3560
3561   my $language = $self->{language} ? '_' . $self->{language} : '';
3562
3563   my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3564   if ($self->{language_id}) {
3565     ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3566   } else {
3567     $output_dateformat   = $::myconfig{dateformat};
3568     $output_numberformat = $::myconfig{numberformat};
3569     $output_longdates    = 1;
3570   }
3571
3572   # Retrieve accounts for tax calculation.
3573   IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3574
3575   if ($self->{type} =~ /_delivery_order$/) {
3576     DO->order_details();
3577   } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3578     OE->order_details(\%::myconfig, $self);
3579   } else {
3580     IS->invoice_details(\%::myconfig, $self, $::locale);
3581   }
3582
3583   # Chose extension & set source file name
3584   my $extension = 'html';
3585   if ($self->{format} eq 'postscript') {
3586     $self->{postscript}   = 1;
3587     $extension            = 'tex';
3588   } elsif ($self->{"format"} =~ /pdf/) {
3589     $self->{pdf}          = 1;
3590     $extension            = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3591   } elsif ($self->{"format"} =~ /opendocument/) {
3592     $self->{opendocument} = 1;
3593     $extension            = 'odt';
3594   } elsif ($self->{"format"} =~ /excel/) {
3595     $self->{excel}        = 1;
3596     $extension            = 'xls';
3597   }
3598
3599   my $printer_code    = '_' . $self->{printer_code} if $self->{printer_code};
3600   my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3601   $self->{IN}         = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3602
3603   # Format dates.
3604   $self->format_dates($output_dateformat, $output_longdates,
3605                       qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3606                          transdate_oe deliverydate_oe employee_startdate employee_enddate),
3607                       grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3608
3609   $self->reformat_numbers($output_numberformat, 2,
3610                           qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3611                           grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3612
3613   $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3614
3615   my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3616
3617   if (scalar @{ $cvar_date_fields }) {
3618     $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3619   }
3620
3621   while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3622     $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3623   }
3624
3625   return $self;
3626 }
3627
3628 sub format_dates {
3629   my ($self, $dateformat, $longformat, @indices) = @_;
3630
3631   $dateformat ||= $::myconfig{dateformat};
3632
3633   foreach my $idx (@indices) {
3634     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3635       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3636         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3637       }
3638     }
3639
3640     next unless defined $self->{$idx};
3641
3642     if (!ref($self->{$idx})) {
3643       $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3644
3645     } elsif (ref($self->{$idx}) eq "ARRAY") {
3646       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3647         $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3648       }
3649     }
3650   }
3651 }
3652
3653 sub reformat_numbers {
3654   my ($self, $numberformat, $places, @indices) = @_;
3655
3656   return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3657
3658   foreach my $idx (@indices) {
3659     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3660       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3661         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3662       }
3663     }
3664
3665     next unless defined $self->{$idx};
3666
3667     if (!ref($self->{$idx})) {
3668       $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3669
3670     } elsif (ref($self->{$idx}) eq "ARRAY") {
3671       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3672         $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3673       }
3674     }
3675   }
3676
3677   my $saved_numberformat    = $::myconfig{numberformat};
3678   $::myconfig{numberformat} = $numberformat;
3679
3680   foreach my $idx (@indices) {
3681     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3682       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3683         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3684       }
3685     }
3686
3687     next unless defined $self->{$idx};
3688
3689     if (!ref($self->{$idx})) {
3690       $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3691
3692     } elsif (ref($self->{$idx}) eq "ARRAY") {
3693       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3694         $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3695       }
3696     }
3697   }
3698
3699   $::myconfig{numberformat} = $saved_numberformat;
3700 }
3701
3702 1;
3703
3704 __END__
3705
3706 =head1 NAME
3707
3708 SL::Form.pm - main data object.
3709
3710 =head1 SYNOPSIS
3711
3712 This is the main data object of Lx-Office.
3713 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3714 Points of interest for a beginner are:
3715
3716  - $form->error            - renders a generic error in html. accepts an error message
3717  - $form->get_standard_dbh - returns a database connection for the
3718
3719 =head1 SPECIAL FUNCTIONS
3720
3721 =head2 C<_store_value()>
3722
3723 parses a complex var name, and stores it in the form.
3724
3725 syntax:
3726   $form->_store_value($key, $value);
3727
3728 keys must start with a string, and can contain various tokens.
3729 supported key structures are:
3730
3731 1. simple access
3732   simple key strings work as expected
3733
3734   id => $form->{id}
3735
3736 2. hash access.
3737   separating two keys by a dot (.) will result in a hash lookup for the inner value
3738   this is similar to the behaviour of java and templating mechanisms.
3739
3740   filter.description => $form->{filter}->{description}
3741
3742 3. array+hashref access
3743
3744   adding brackets ([]) before the dot will cause the next hash to be put into an array.
3745   using [+] instead of [] will force a new array index. this is useful for recurring
3746   data structures like part lists. put a [+] into the first varname, and use [] on the
3747   following ones.
3748
3749   repeating these names in your template:
3750
3751     invoice.items[+].id
3752     invoice.items[].parts_id
3753
3754   will result in:
3755
3756     $form->{invoice}->{items}->[
3757       {
3758         id       => ...
3759         parts_id => ...
3760       },
3761       {
3762         id       => ...
3763         parts_id => ...
3764       }
3765       ...
3766     ]
3767
3768 4. arrays
3769
3770   using brackets at the end of a name will result in a pure array to be created.
3771   note that you mustn't use [+], which is reserved for array+hash access and will
3772   result in undefined behaviour in array context.
3773
3774   filter.status[]  => $form->{status}->[ val1, val2, ... ]
3775
3776 =head2 C<update_business> PARAMS
3777
3778 PARAMS (not named):
3779  \%config,     - config hashref
3780  $business_id, - business id
3781  $dbh          - optional database handle
3782
3783 handles business (thats customer/vendor types) sequences.
3784
3785 special behaviour for empty strings in customerinitnumber field:
3786 will in this case not increase the value, and return undef.
3787
3788 =head2 C<redirect_header> $url
3789
3790 Generates a HTTP redirection header for the new C<$url>. Constructs an
3791 absolute URL including scheme, host name and port. If C<$url> is a
3792 relative URL then it is considered relative to Lx-Office base URL.
3793
3794 This function C<die>s if headers have already been created with
3795 C<$::form-E<gt>header>.
3796
3797 Examples:
3798
3799   print $::form->redirect_header('oe.pl?action=edit&id=1234');
3800   print $::form->redirect_header('http://www.lx-office.org/');
3801
3802 =head2 C<header>
3803
3804 Generates a general purpose http/html header and includes most of the scripts
3805 ans stylesheets needed.
3806
3807 Only one header will be generated. If the method was already called in this
3808 request it will not output anything and return undef. Also if no
3809 HTTP_USER_AGENT is found, no header is generated.
3810
3811 Although header does not accept parameters itself, it will honor special
3812 hashkeys of its Form instance:
3813
3814 =over 4
3815
3816 =item refresh_time
3817
3818 =item refresh_url
3819
3820 If one of these is set, a http-equiv refresh is generated. Missing parameters
3821 default to 3 seconds and the refering url.
3822
3823 =item stylesheet
3824
3825 =item stylesheets
3826
3827 If these are arrayrefs the contents will be inlined into the header.
3828
3829 =item landscape
3830
3831 If true, a css snippet will be generated that sets the page in landscape mode.
3832
3833 =item favicon
3834
3835 Used to override the default favicon.
3836
3837 =item title
3838
3839 A html page title will be generated from this
3840
3841 =back
3842
3843 =cut