SL/Form.pm

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