SL/Form.pm

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