SL/Form.pm

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