SL/Form.pm

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