SL/Form.pm

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