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