SL/Form.pm

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