SL/Form.pm

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