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     if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
 783       my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
 784         "Please re-run 'locales.pl' in 'locale/${language}'.";
 785       print(qq|<pre>$info</pre>|);
 786       ::end_of_request();
 787     }
 788
 789     $file = "templates/webpages/${file}.html";
 790
 791   } else {
 792     my $info = "Web page template '${file}' not found.\n";
 793     print qq|<pre>$info</pre>|;
 794     ::end_of_request();
 795   }
 796
 797   if ($self->{"DEBUG"}) {
 798     $additional_params->{"DEBUG"} = $self->{"DEBUG"};
 799   }
 800
 801   if ($additional_params->{"DEBUG"}) {
 802     $additional_params->{"DEBUG"} =
 803       "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
 804   }
 805
 806   if (%main::myconfig) {
 807     $::myconfig{jsc_dateformat} = apply {
 808       s/d+/\%d/gi;
 809       s/m+/\%m/gi;
 810       s/y+/\%Y/gi;
 811     } $::myconfig{"dateformat"};
 812     $additional_params->{"myconfig"} ||= \%::myconfig;
 813     map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
 814   }
 815
 816   $additional_params->{"conf_dbcharset"}              = $::lx_office_conf{system}->{dbcharset};
 817   $additional_params->{"conf_webdav"}                 = $::lx_office_conf{features}->{webdav};
 818   $additional_params->{"conf_lizenzen"}               = $::lx_office_conf{features}->{lizenzen};
 819   $additional_params->{"conf_latex_templates"}        = $::lx_office_conf{print_templates}->{latex};
 820   $additional_params->{"conf_opendocument_templates"} = $::lx_office_conf{print_templates}->{opendocument};
 821   $additional_params->{"conf_vertreter"}              = $::lx_office_conf{features}->{vertreter};
 822   $additional_params->{"conf_show_best_before"}       = $::lx_office_conf{features}->{show_best_before};
 823   $additional_params->{"conf_parts_image_css"}        = $::lx_office_conf{features}->{parts_image_css};
 824   $additional_params->{"conf_parts_listing_images"}   = $::lx_office_conf{features}->{parts_listing_images};
 825   $additional_params->{"conf_parts_show_image"}       = $::lx_office_conf{features}->{parts_show_image};
 826
 827   if (%main::debug_options) {
 828     map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
 829   }
 830
 831   if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
 832     while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
 833       $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
 834     }
 835   }
 836
 837   $main::lxdebug->leave_sub();
 838
 839   return $file;
 840 }
 841
 842 sub parse_html_template {
 843   $main::lxdebug->enter_sub();
 844
 845   my ($self, $file, $additional_params) = @_;
 846
 847   $additional_params ||= { };
 848
 849   my $real_file = $self->_prepare_html_template($file, $additional_params);
 850   my $template  = $self->template || $self->init_template;
 851
 852   map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
 853
 854   my $output;
 855   $template->process($real_file, $additional_params, \$output) || die $template->error;
 856
 857   $main::lxdebug->leave_sub();
 858
 859   return $output;
 860 }
 861
 862 sub init_template {
 863   my $self = shift;
 864
 865   return if $self->template;
 866
 867   return $self->template(Template->new({
 868      'INTERPOLATE'  => 0,
 869      'EVAL_PERL'    => 0,
 870      'ABSOLUTE'     => 1,
 871      'CACHE_SIZE'   => 0,
 872      'PLUGIN_BASE'  => 'SL::Template::Plugin',
 873      'INCLUDE_PATH' => '.:templates/webpages',
 874      'COMPILE_EXT'  => '.tcc',
 875      'COMPILE_DIR'  => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
 876   })) || die;
 877 }
 878
 879 sub template {
 880   my $self = shift;
 881   $self->{template_object} = shift if @_;
 882   return $self->{template_object};
 883 }
 884
 885 sub show_generic_error {
 886   $main::lxdebug->enter_sub();
 887
 888   my ($self, $error, %params) = @_;
 889
 890   if ($self->{__ERROR_HANDLER}) {
 891     $self->{__ERROR_HANDLER}->($error);
 892     $main::lxdebug->leave_sub();
 893     return;
 894   }
 895
 896   my $add_params = {
 897     'title_error' => $params{title},
 898     'label_error' => $error,
 899   };
 900
 901   if ($params{action}) {
 902     my @vars;
 903
 904     map { delete($self->{$_}); } qw(action);
 905     map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
 906
 907     $add_params->{SHOW_BUTTON}  = 1;
 908     $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
 909     $add_params->{VARIABLES}    = \@vars;
 910
 911   } elsif ($params{back_button}) {
 912     $add_params->{SHOW_BACK_BUTTON} = 1;
 913   }
 914
 915   $self->{title} = $params{title} if $params{title};
 916
 917   $self->header();
 918   print $self->parse_html_template("generic/error", $add_params);
 919
 920   print STDERR "Error: $error\n";
 921
 922   $main::lxdebug->leave_sub();
 923
 924   ::end_of_request();
 925 }
 926
 927 sub show_generic_information {
 928   $main::lxdebug->enter_sub();
 929
 930   my ($self, $text, $title) = @_;
 931
 932   my $add_params = {
 933     'title_information' => $title,
 934     'label_information' => $text,
 935   };
 936
 937   $self->{title} = $title if ($title);
 938
 939   $self->header();
 940   print $self->parse_html_template("generic/information", $add_params);
 941
 942   $main::lxdebug->leave_sub();
 943
 944   ::end_of_request();
 945 }
 946
 947 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
 948 # changed it to accept an arbitrary number of triggers - sschoeling
 949 sub write_trigger {
 950   $main::lxdebug->enter_sub();
 951
 952   my $self     = shift;
 953   my $myconfig = shift;
 954   my $qty      = shift;
 955
 956   # set dateform for jsscript
 957   # default
 958   my %dateformats = (
 959     "dd.mm.yy" => "%d.%m.%Y",
 960     "dd-mm-yy" => "%d-%m-%Y",
 961     "dd/mm/yy" => "%d/%m/%Y",
 962     "mm/dd/yy" => "%m/%d/%Y",
 963     "mm-dd-yy" => "%m-%d-%Y",
 964     "yyyy-mm-dd" => "%Y-%m-%d",
 965     );
 966
 967   my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
 968     $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
 969
 970   my @triggers;
 971   while ($#_ >= 2) {
 972     push @triggers, qq|
 973        Calendar.setup(
 974       {
 975       inputField : "| . (shift) . qq|",
 976       ifFormat :"$ifFormat",
 977       align : "| .  (shift) . qq|",
 978       button : "| . (shift) . qq|"
 979       }
 980       );
 981        |;
 982   }
 983   my $jsscript = qq|
 984        <script type="text/javascript">
 985        <!--| . join("", @triggers) . qq|//-->
 986         </script>
 987         |;
 988
 989   $main::lxdebug->leave_sub();
 990
 991   return $jsscript;
 992 }    #end sub write_trigger
 993
 994 sub redirect {
 995   $main::lxdebug->enter_sub();
 996
 997   my ($self, $msg) = @_;
 998
 999   if (!$self->{callback}) {
1000     $self->info($msg);
1001
1002   } else {
1003     print $::form->redirect_header($self->{callback});
1004   }
1005
1006   ::end_of_request();
1007
1008   $main::lxdebug->leave_sub();
1009 }
1010
1011 # sort of columns removed - empty sub
1012 sub sort_columns {
1013   $main::lxdebug->enter_sub();
1014
1015   my ($self, @columns) = @_;
1016
1017   $main::lxdebug->leave_sub();
1018
1019   return @columns;
1020 }
1021 #
1022 sub format_amount {
1023   $main::lxdebug->enter_sub(2);
1024
1025   my ($self, $myconfig, $amount, $places, $dash) = @_;
1026
1027   if ($amount eq "") {
1028     $amount = 0;
1029   }
1030
1031   # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1032
1033   my $neg = ($amount =~ s/^-//);
1034   my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1035
1036   if (defined($places) && ($places ne '')) {
1037     if (not $exp) {
1038       if ($places < 0) {
1039         $amount *= 1;
1040         $places *= -1;
1041
1042         my ($actual_places) = ($amount =~ /\.(\d+)/);
1043         $actual_places = length($actual_places);
1044         $places = $actual_places > $places ? $actual_places : $places;
1045       }
1046     }
1047     $amount = $self->round_amount($amount, $places);
1048   }
1049
1050   my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1051   my @p = split(/\./, $amount); # split amount at decimal point
1052
1053   $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1054
1055   $amount = $p[0];
1056   $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1057
1058   $amount = do {
1059     ($dash =~ /-/)    ? ($neg ? "($amount)"                            : "$amount" )                              :
1060     ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1061                         ($neg ? "-$amount"                             : "$amount" )                              ;
1062   };
1063
1064
1065   $main::lxdebug->leave_sub(2);
1066   return $amount;
1067 }
1068
1069 sub format_amount_units {
1070   $main::lxdebug->enter_sub();
1071
1072   my $self             = shift;
1073   my %params           = @_;
1074
1075   my $myconfig         = \%main::myconfig;
1076   my $amount           = $params{amount} * 1;
1077   my $places           = $params{places};
1078   my $part_unit_name   = $params{part_unit};
1079   my $amount_unit_name = $params{amount_unit};
1080   my $conv_units       = $params{conv_units};
1081   my $max_places       = $params{max_places};
1082
1083   if (!$part_unit_name) {
1084     $main::lxdebug->leave_sub();
1085     return '';
1086   }
1087
1088   AM->retrieve_all_units();
1089   my $all_units        = $main::all_units;
1090
1091   if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1092     $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1093   }
1094
1095   if (!scalar @{ $conv_units }) {
1096     my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1097     $main::lxdebug->leave_sub();
1098     return $result;
1099   }
1100
1101   my $part_unit  = $all_units->{$part_unit_name};
1102   my $conv_unit  = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1103
1104   $amount       *= $conv_unit->{factor};
1105
1106   my @values;
1107   my $num;
1108
1109   foreach my $unit (@$conv_units) {
1110     my $last = $unit->{name} eq $part_unit->{name};
1111     if (!$last) {
1112       $num     = int($amount / $unit->{factor});
1113       $amount -= $num * $unit->{factor};
1114     }
1115
1116     if ($last ? $amount : $num) {
1117       push @values, { "unit"   => $unit->{name},
1118                       "amount" => $last ? $amount / $unit->{factor} : $num,
1119                       "places" => $last ? $places : 0 };
1120     }
1121
1122     last if $last;
1123   }
1124
1125   if (!@values) {
1126     push @values, { "unit"   => $part_unit_name,
1127                     "amount" => 0,
1128                     "places" => 0 };
1129   }
1130
1131   my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1132
1133   $main::lxdebug->leave_sub();
1134
1135   return $result;
1136 }
1137
1138 sub format_string {
1139   $main::lxdebug->enter_sub(2);
1140
1141   my $self  = shift;
1142   my $input = shift;
1143
1144   $input =~ s/(^|[^\#]) \#  (\d+)  /$1$_[$2 - 1]/gx;
1145   $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1146   $input =~ s/\#\#/\#/g;
1147
1148   $main::lxdebug->leave_sub(2);
1149
1150   return $input;
1151 }
1152
1153 #
1154
1155 sub parse_amount {
1156   $main::lxdebug->enter_sub(2);
1157
1158   my ($self, $myconfig, $amount) = @_;
1159
1160   if (   ($myconfig->{numberformat} eq '1.000,00')
1161       || ($myconfig->{numberformat} eq '1000,00')) {
1162     $amount =~ s/\.//g;
1163     $amount =~ s/,/\./;
1164   }
1165
1166   if ($myconfig->{numberformat} eq "1'000.00") {
1167     $amount =~ s/\'//g;
1168   }
1169
1170   $amount =~ s/,//g;
1171
1172   $main::lxdebug->leave_sub(2);
1173
1174   return ($amount * 1);
1175 }
1176
1177 sub round_amount {
1178   $main::lxdebug->enter_sub(2);
1179
1180   my ($self, $amount, $places) = @_;
1181   my $round_amount;
1182
1183   # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1184
1185   # Round amounts to eight places before rounding to the requested
1186   # number of places. This gets rid of errors due to internal floating
1187   # point representation.
1188   $amount       = $self->round_amount($amount, 8) if $places < 8;
1189   $amount       = $amount * (10**($places));
1190   $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1191
1192   $main::lxdebug->leave_sub(2);
1193
1194   return $round_amount;
1195
1196 }
1197
1198 sub parse_template {
1199   $main::lxdebug->enter_sub();
1200
1201   my ($self, $myconfig) = @_;
1202   my $out;
1203
1204   local (*IN, *OUT);
1205
1206   my $userspath = $::lx_office_conf{paths}->{userspath};
1207
1208   $self->{"cwd"} = getcwd();
1209   $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1210
1211   my $ext_for_format;
1212
1213   my $template_type;
1214   if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1215     $template_type  = 'OpenDocument';
1216     $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1217
1218   } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1219     $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1220     $template_type    = 'LaTeX';
1221     $ext_for_format   = 'pdf';
1222
1223   } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1224     $template_type  = 'HTML';
1225     $ext_for_format = 'html';
1226
1227   } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1228     $template_type  = 'XML';
1229     $ext_for_format = 'xml';
1230
1231   } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1232     $template_type = 'XML';
1233
1234   } elsif ( $self->{"format"} =~ /excel/i ) {
1235     $template_type  = 'Excel';
1236     $ext_for_format = 'xls';
1237
1238   } elsif ( defined $self->{'format'}) {
1239     $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1240
1241   } elsif ( $self->{'format'} eq '' ) {
1242     $self->error("No Outputformat given: $self->{'format'}");
1243
1244   } else { #Catch the rest
1245     $self->error("Outputformat not defined: $self->{'format'}");
1246   }
1247
1248   my $template = SL::Template::create(type      => $template_type,
1249                                       file_name => $self->{IN},
1250                                       form      => $self,
1251                                       myconfig  => $myconfig,
1252                                       userspath => $userspath);
1253
1254   # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1255   $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1256
1257   if (!$self->{employee_id}) {
1258     map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1259   }
1260
1261   map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1262   map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1263
1264   $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1265
1266   # OUT is used for the media, screen, printer, email
1267   # for postscript we store a copy in a temporary file
1268   my $fileid = time;
1269   my $prepend_userspath;
1270
1271   if (!$self->{tmpfile}) {
1272     $self->{tmpfile}   = "${fileid}.$self->{IN}";
1273     $prepend_userspath = 1;
1274   }
1275
1276   $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1277
1278   $self->{tmpfile} =~ s|.*/||;
1279   $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1280   $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1281
1282   if ($template->uses_temp_file() || $self->{media} eq 'email') {
1283     $out = $self->{OUT};
1284     $self->{OUT} = ">$self->{tmpfile}";
1285   }
1286
1287   my $result;
1288
1289   if ($self->{OUT}) {
1290     open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1291     $result = $template->parse(*OUT);
1292     close OUT;
1293
1294   } else {
1295     $self->header;
1296     $result = $template->parse(*STDOUT);
1297   }
1298
1299   if (!$result) {
1300     $self->cleanup();
1301     $self->error("$self->{IN} : " . $template->get_error());
1302   }
1303
1304   if ($self->{media} eq 'file') {
1305     copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1306     $self->cleanup;
1307     chdir("$self->{cwd}");
1308
1309     $::lxdebug->leave_sub();
1310
1311     return;
1312   }
1313
1314   if ($template->uses_temp_file() || $self->{media} eq 'email') {
1315
1316     if ($self->{media} eq 'email') {
1317
1318       my $mail = new Mailer;
1319
1320       map { $mail->{$_} = $self->{$_} }
1321         qw(cc bcc subject message version format);
1322       $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1323       $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1324       $mail->{from}   = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1325       $mail->{fileid} = "$fileid.";
1326       $myconfig->{signature} =~ s/\r//g;
1327
1328       # if we send html or plain text inline
1329       if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1330         $mail->{contenttype} = "text/html";
1331
1332         $mail->{message}       =~ s/\r//g;
1333         $mail->{message}       =~ s/\n/<br>\n/g;
1334         $myconfig->{signature} =~ s/\n/<br>\n/g;
1335         $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1336
1337         open(IN, $self->{tmpfile})
1338           or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1339         while (<IN>) {
1340           $mail->{message} .= $_;
1341         }
1342
1343         close(IN);
1344
1345       } else {
1346
1347         if (!$self->{"do_not_attach"}) {
1348           my $attachment_name  =  $self->{attachment_filename} || $self->{tmpfile};
1349           $attachment_name     =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1350           $mail->{attachments} =  [{ "filename" => $self->{tmpfile},
1351                                      "name"     => $attachment_name }];
1352         }
1353
1354         $mail->{message}  =~ s/\r//g;
1355         $mail->{message} .=  "\n-- \n$myconfig->{signature}";
1356
1357       }
1358
1359       my $err = $mail->send();
1360       $self->error($self->cleanup . "$err") if ($err);
1361
1362     } else {
1363
1364       $self->{OUT} = $out;
1365
1366       my $numbytes = (-s $self->{tmpfile});
1367       open(IN, $self->{tmpfile})
1368         or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1369       binmode IN;
1370
1371       $self->{copies} = 1 unless $self->{media} eq 'printer';
1372
1373       chdir("$self->{cwd}");
1374       #print(STDERR "Kopien $self->{copies}\n");
1375       #print(STDERR "OUT $self->{OUT}\n");
1376       for my $i (1 .. $self->{copies}) {
1377         if ($self->{OUT}) {
1378           open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1379           print OUT while <IN>;
1380           close OUT;
1381           seek IN, 0, 0;
1382
1383         } else {
1384           $self->{attachment_filename} = ($self->{attachment_filename})
1385                                        ? $self->{attachment_filename}
1386                                        : $self->generate_attachment_filename();
1387
1388           # launch application
1389           print qq|Content-Type: | . $template->get_mime_type() . qq|
1390 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1391 Content-Length: $numbytes
1392
1393 |;
1394
1395           $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1396         }
1397       }
1398
1399       close(IN);
1400     }
1401
1402   }
1403
1404   $self->cleanup;
1405
1406   chdir("$self->{cwd}");
1407   $main::lxdebug->leave_sub();
1408 }
1409
1410 sub get_formname_translation {
1411   $main::lxdebug->enter_sub();
1412   my ($self, $formname) = @_;
1413
1414   $formname ||= $self->{formname};
1415
1416   my %formname_translations = (
1417     bin_list                => $main::locale->text('Bin List'),
1418     credit_note             => $main::locale->text('Credit Note'),
1419     invoice                 => $main::locale->text('Invoice'),
1420     pick_list               => $main::locale->text('Pick List'),
1421     proforma                => $main::locale->text('Proforma Invoice'),
1422     purchase_order          => $main::locale->text('Purchase Order'),
1423     request_quotation       => $main::locale->text('RFQ'),
1424     sales_order             => $main::locale->text('Confirmation'),
1425     sales_quotation         => $main::locale->text('Quotation'),
1426     storno_invoice          => $main::locale->text('Storno Invoice'),
1427     sales_delivery_order    => $main::locale->text('Delivery Order'),
1428     purchase_delivery_order => $main::locale->text('Delivery Order'),
1429     dunning                 => $main::locale->text('Dunning'),
1430   );
1431
1432   $main::lxdebug->leave_sub();
1433   return $formname_translations{$formname}
1434 }
1435
1436 sub get_number_prefix_for_type {
1437   $main::lxdebug->enter_sub();
1438   my ($self) = @_;
1439
1440   my $prefix =
1441       (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1442     : ($self->{type} =~ /_quotation$/)                        ? 'quo'
1443     : ($self->{type} =~ /_delivery_order$/)                   ? 'do'
1444     :                                                           'ord';
1445
1446   $main::lxdebug->leave_sub();
1447   return $prefix;
1448 }
1449
1450 sub get_extension_for_format {
1451   $main::lxdebug->enter_sub();
1452   my ($self)    = @_;
1453
1454   my $extension = $self->{format} =~ /pdf/i          ? ".pdf"
1455                 : $self->{format} =~ /postscript/i   ? ".ps"
1456                 : $self->{format} =~ /opendocument/i ? ".odt"
1457                 : $self->{format} =~ /excel/i        ? ".xls"
1458                 : $self->{format} =~ /html/i         ? ".html"
1459                 :                                      "";
1460
1461   $main::lxdebug->leave_sub();
1462   return $extension;
1463 }
1464
1465 sub generate_attachment_filename {
1466   $main::lxdebug->enter_sub();
1467   my ($self) = @_;
1468
1469   my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1470   my $prefix              = $self->get_number_prefix_for_type();
1471
1472   if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1473     $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1474
1475   } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1476     $attachment_filename .=  "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1477
1478   } else {
1479     $attachment_filename = "";
1480   }
1481
1482   $attachment_filename =  $main::locale->quote_special_chars('filenames', $attachment_filename);
1483   $attachment_filename =~ s|[\s/\\]+|_|g;
1484
1485   $main::lxdebug->leave_sub();
1486   return $attachment_filename;
1487 }
1488
1489 sub generate_email_subject {
1490   $main::lxdebug->enter_sub();
1491   my ($self) = @_;
1492
1493   my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1494   my $prefix  = $self->get_number_prefix_for_type();
1495
1496   if ($subject && $self->{"${prefix}number"}) {
1497     $subject .= " " . $self->{"${prefix}number"}
1498   }
1499
1500   $main::lxdebug->leave_sub();
1501   return $subject;
1502 }
1503
1504 sub cleanup {
1505   $main::lxdebug->enter_sub();
1506
1507   my $self = shift;
1508
1509   chdir("$self->{tmpdir}");
1510
1511   my @err = ();
1512   if (-f "$self->{tmpfile}.err") {
1513     open(FH, "$self->{tmpfile}.err");
1514     @err = <FH>;
1515     close(FH);
1516   }
1517
1518   if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1519     $self->{tmpfile} =~ s|.*/||g;
1520     # strip extension
1521     $self->{tmpfile} =~ s/\.\w+$//g;
1522     my $tmpfile = $self->{tmpfile};
1523     unlink(<$tmpfile.*>);
1524   }
1525
1526   chdir("$self->{cwd}");
1527
1528   $main::lxdebug->leave_sub();
1529
1530   return "@err";
1531 }
1532
1533 sub datetonum {
1534   $main::lxdebug->enter_sub();
1535
1536   my ($self, $date, $myconfig) = @_;
1537   my ($yy, $mm, $dd);
1538
1539   if ($date && $date =~ /\D/) {
1540
1541     if ($myconfig->{dateformat} =~ /^yy/) {
1542       ($yy, $mm, $dd) = split /\D/, $date;
1543     }
1544     if ($myconfig->{dateformat} =~ /^mm/) {
1545       ($mm, $dd, $yy) = split /\D/, $date;
1546     }
1547     if ($myconfig->{dateformat} =~ /^dd/) {
1548       ($dd, $mm, $yy) = split /\D/, $date;
1549     }
1550
1551     $dd *= 1;
1552     $mm *= 1;
1553     $yy = ($yy < 70) ? $yy + 2000 : $yy;
1554     $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1555
1556     $dd = "0$dd" if ($dd < 10);
1557     $mm = "0$mm" if ($mm < 10);
1558
1559     $date = "$yy$mm$dd";
1560   }
1561
1562   $main::lxdebug->leave_sub();
1563
1564   return $date;
1565 }
1566
1567 # Database routines used throughout
1568
1569 sub _dbconnect_options {
1570   my $self    = shift;
1571   my $options = { pg_enable_utf8 => $::locale->is_utf8,
1572                   @_ };
1573
1574   return $options;
1575 }
1576
1577 sub dbconnect {
1578   $main::lxdebug->enter_sub(2);
1579
1580   my ($self, $myconfig) = @_;
1581
1582   # connect to database
1583   my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1584     or $self->dberror;
1585
1586   # set db options
1587   if ($myconfig->{dboptions}) {
1588     $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1589   }
1590
1591   $main::lxdebug->leave_sub(2);
1592
1593   return $dbh;
1594 }
1595
1596 sub dbconnect_noauto {
1597   $main::lxdebug->enter_sub();
1598
1599   my ($self, $myconfig) = @_;
1600
1601   # connect to database
1602   my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1603     or $self->dberror;
1604
1605   # set db options
1606   if ($myconfig->{dboptions}) {
1607     $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1608   }
1609
1610   $main::lxdebug->leave_sub();
1611
1612   return $dbh;
1613 }
1614
1615 sub get_standard_dbh {
1616   $main::lxdebug->enter_sub(2);
1617
1618   my $self     = shift;
1619   my $myconfig = shift || \%::myconfig;
1620
1621   if ($standard_dbh && !$standard_dbh->{Active}) {
1622     $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1623     undef $standard_dbh;
1624   }
1625
1626   $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1627
1628   $main::lxdebug->leave_sub(2);
1629
1630   return $standard_dbh;
1631 }
1632
1633 sub date_closed {
1634   $main::lxdebug->enter_sub();
1635
1636   my ($self, $date, $myconfig) = @_;
1637   my $dbh = $self->dbconnect($myconfig);
1638
1639   my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1640   my $sth = prepare_execute_query($self, $dbh, $query, $date);
1641   my ($closed) = $sth->fetchrow_array;
1642
1643   $main::lxdebug->leave_sub();
1644
1645   return $closed;
1646 }
1647
1648 sub update_balance {
1649   $main::lxdebug->enter_sub();
1650
1651   my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1652
1653   # if we have a value, go do it
1654   if ($value != 0) {
1655
1656     # retrieve balance from table
1657     my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1658     my $sth = prepare_execute_query($self, $dbh, $query, @values);
1659     my ($balance) = $sth->fetchrow_array;
1660     $sth->finish;
1661
1662     $balance += $value;
1663
1664     # update balance
1665     $query = "UPDATE $table SET $field = $balance WHERE $where";
1666     do_query($self, $dbh, $query, @values);
1667   }
1668   $main::lxdebug->leave_sub();
1669 }
1670
1671 sub update_exchangerate {
1672   $main::lxdebug->enter_sub();
1673
1674   my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1675   my ($query);
1676   # some sanity check for currency
1677   if ($curr eq '') {
1678     $main::lxdebug->leave_sub();
1679     return;
1680   }
1681   $query = qq|SELECT curr FROM defaults|;
1682
1683   my ($currency) = selectrow_query($self, $dbh, $query);
1684   my ($defaultcurrency) = split m/:/, $currency;
1685
1686
1687   if ($curr eq $defaultcurrency) {
1688     $main::lxdebug->leave_sub();
1689     return;
1690   }
1691
1692   $query = qq|SELECT e.curr FROM exchangerate e
1693                  WHERE e.curr = ? AND e.transdate = ?
1694                  FOR UPDATE|;
1695   my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1696
1697   if ($buy == 0) {
1698     $buy = "";
1699   }
1700   if ($sell == 0) {
1701     $sell = "";
1702   }
1703
1704   $buy = conv_i($buy, "NULL");
1705   $sell = conv_i($sell, "NULL");
1706
1707   my $set;
1708   if ($buy != 0 && $sell != 0) {
1709     $set = "buy = $buy, sell = $sell";
1710   } elsif ($buy != 0) {
1711     $set = "buy = $buy";
1712   } elsif ($sell != 0) {
1713     $set = "sell = $sell";
1714   }
1715
1716   if ($sth->fetchrow_array) {
1717     $query = qq|UPDATE exchangerate
1718                 SET $set
1719                 WHERE curr = ?
1720                 AND transdate = ?|;
1721
1722   } else {
1723     $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1724                 VALUES (?, $buy, $sell, ?)|;
1725   }
1726   $sth->finish;
1727   do_query($self, $dbh, $query, $curr, $transdate);
1728
1729   $main::lxdebug->leave_sub();
1730 }
1731
1732 sub save_exchangerate {
1733   $main::lxdebug->enter_sub();
1734
1735   my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1736
1737   my $dbh = $self->dbconnect($myconfig);
1738
1739   my ($buy, $sell);
1740
1741   $buy  = $rate if $fld eq 'buy';
1742   $sell = $rate if $fld eq 'sell';
1743
1744
1745   $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1746
1747
1748   $dbh->disconnect;
1749
1750   $main::lxdebug->leave_sub();
1751 }
1752
1753 sub get_exchangerate {
1754   $main::lxdebug->enter_sub();
1755
1756   my ($self, $dbh, $curr, $transdate, $fld) = @_;
1757   my ($query);
1758
1759   unless ($transdate) {
1760     $main::lxdebug->leave_sub();
1761     return 1;
1762   }
1763
1764   $query = qq|SELECT curr FROM defaults|;
1765
1766   my ($currency) = selectrow_query($self, $dbh, $query);
1767   my ($defaultcurrency) = split m/:/, $currency;
1768
1769   if ($currency eq $defaultcurrency) {
1770     $main::lxdebug->leave_sub();
1771     return 1;
1772   }
1773
1774   $query = qq|SELECT e.$fld FROM exchangerate e
1775                  WHERE e.curr = ? AND e.transdate = ?|;
1776   my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1777
1778
1779
1780   $main::lxdebug->leave_sub();
1781
1782   return $exchangerate;
1783 }
1784
1785 sub check_exchangerate {
1786   $main::lxdebug->enter_sub();
1787
1788   my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1789
1790   if ($fld !~/^buy|sell$/) {
1791     $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1792   }
1793
1794   unless ($transdate) {
1795     $main::lxdebug->leave_sub();
1796     return "";
1797   }
1798
1799   my ($defaultcurrency) = $self->get_default_currency($myconfig);
1800
1801   if ($currency eq $defaultcurrency) {
1802     $main::lxdebug->leave_sub();
1803     return 1;
1804   }
1805
1806   my $dbh   = $self->get_standard_dbh($myconfig);
1807   my $query = qq|SELECT e.$fld FROM exchangerate e
1808                  WHERE e.curr = ? AND e.transdate = ?|;
1809
1810   my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1811
1812   $main::lxdebug->leave_sub();
1813
1814   return $exchangerate;
1815 }
1816
1817 sub get_all_currencies {
1818   $main::lxdebug->enter_sub();
1819
1820   my $self     = shift;
1821   my $myconfig = shift || \%::myconfig;
1822   my $dbh      = $self->get_standard_dbh($myconfig);
1823
1824   my $query = qq|SELECT curr FROM defaults|;
1825
1826   my ($curr)     = selectrow_query($self, $dbh, $query);
1827   my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1828
1829   $main::lxdebug->leave_sub();
1830
1831   return @currencies;
1832 }
1833
1834 sub get_default_currency {
1835   $main::lxdebug->enter_sub();
1836
1837   my ($self, $myconfig) = @_;
1838   my @currencies        = $self->get_all_currencies($myconfig);
1839
1840   $main::lxdebug->leave_sub();
1841
1842   return $currencies[0];
1843 }
1844
1845 sub set_payment_options {
1846   $main::lxdebug->enter_sub();
1847
1848   my ($self, $myconfig, $transdate) = @_;
1849
1850   return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1851
1852   my $dbh = $self->get_standard_dbh($myconfig);
1853
1854   my $query =
1855     qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1856     qq|FROM payment_terms p | .
1857     qq|WHERE p.id = ?|;
1858
1859   ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1860    $self->{payment_terms}) =
1861      selectrow_query($self, $dbh, $query, $self->{payment_id});
1862
1863   if ($transdate eq "") {
1864     if ($self->{invdate}) {
1865       $transdate = $self->{invdate};
1866     } else {
1867       $transdate = $self->{transdate};
1868     }
1869   }
1870
1871   $query =
1872     qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1873     qq|FROM payment_terms|;
1874   ($self->{netto_date}, $self->{skonto_date}) =
1875     selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1876
1877   my ($invtotal, $total);
1878   my (%amounts, %formatted_amounts);
1879
1880   if ($self->{type} =~ /_order$/) {
1881     $amounts{invtotal} = $self->{ordtotal};
1882     $amounts{total}    = $self->{ordtotal};
1883
1884   } elsif ($self->{type} =~ /_quotation$/) {
1885     $amounts{invtotal} = $self->{quototal};
1886     $amounts{total}    = $self->{quototal};
1887
1888   } else {
1889     $amounts{invtotal} = $self->{invtotal};
1890     $amounts{total}    = $self->{total};
1891   }
1892   $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1893
1894   map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1895
1896   $amounts{skonto_amount}      = $amounts{invtotal} * $self->{percent_skonto};
1897   $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1898   $amounts{total_wo_skonto}    = $amounts{total}    * (1 - $self->{percent_skonto});
1899
1900   foreach (keys %amounts) {
1901     $amounts{$_}           = $self->round_amount($amounts{$_}, 2);
1902     $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1903   }
1904
1905   if ($self->{"language_id"}) {
1906     $query =
1907       qq|SELECT t.translation, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1908       qq|FROM generic_translations t | .
1909       qq|LEFT JOIN language l ON t.language_id = l.id | .
1910       qq|WHERE (t.language_id = ?)
1911            AND (t.translation_id = ?)
1912            AND (t.translation_type = 'SL::DB::PaymentTerm/description_long')|;
1913     my ($description_long, $output_numberformat, $output_dateformat,
1914       $output_longdates) =
1915       selectrow_query($self, $dbh, $query,
1916                       $self->{"language_id"}, $self->{"payment_id"});
1917
1918     $self->{payment_terms} = $description_long if ($description_long);
1919
1920     if ($output_dateformat) {
1921       foreach my $key (qw(netto_date skonto_date)) {
1922         $self->{$key} =
1923           $main::locale->reformat_date($myconfig, $self->{$key},
1924                                        $output_dateformat,
1925                                        $output_longdates);
1926       }
1927     }
1928
1929     if ($output_numberformat &&
1930         ($output_numberformat ne $myconfig->{"numberformat"})) {
1931       my $saved_numberformat = $myconfig->{"numberformat"};
1932       $myconfig->{"numberformat"} = $output_numberformat;
1933       map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1934       $myconfig->{"numberformat"} = $saved_numberformat;
1935     }
1936   }
1937
1938   $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1939   $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1940   $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1941   $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1942   $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1943   $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1944   $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1945
1946   map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1947
1948   $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1949
1950   $main::lxdebug->leave_sub();
1951
1952 }
1953
1954 sub get_template_language {
1955   $main::lxdebug->enter_sub();
1956
1957   my ($self, $myconfig) = @_;
1958
1959   my $template_code = "";
1960
1961   if ($self->{language_id}) {
1962     my $dbh = $self->get_standard_dbh($myconfig);
1963     my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1964     ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1965   }
1966
1967   $main::lxdebug->leave_sub();
1968
1969   return $template_code;
1970 }
1971
1972 sub get_printer_code {
1973   $main::lxdebug->enter_sub();
1974
1975   my ($self, $myconfig) = @_;
1976
1977   my $template_code = "";
1978
1979   if ($self->{printer_id}) {
1980     my $dbh = $self->get_standard_dbh($myconfig);
1981     my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1982     ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1983   }
1984
1985   $main::lxdebug->leave_sub();
1986
1987   return $template_code;
1988 }
1989
1990 sub get_shipto {
1991   $main::lxdebug->enter_sub();
1992
1993   my ($self, $myconfig) = @_;
1994
1995   my $template_code = "";
1996
1997   if ($self->{shipto_id}) {
1998     my $dbh = $self->get_standard_dbh($myconfig);
1999     my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
2000     my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
2001     map({ $self->{$_} = $ref->{$_} } keys(%$ref));
2002   }
2003
2004   $main::lxdebug->leave_sub();
2005 }
2006
2007 sub add_shipto {
2008   $main::lxdebug->enter_sub();
2009
2010   my ($self, $dbh, $id, $module) = @_;
2011
2012   my $shipto;
2013   my @values;
2014
2015   foreach my $item (qw(name department_1 department_2 street zipcode city country
2016                        contact cp_gender phone fax email)) {
2017     if ($self->{"shipto$item"}) {
2018       $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2019     }
2020     push(@values, $self->{"shipto${item}"});
2021   }
2022
2023   if ($shipto) {
2024     if ($self->{shipto_id}) {
2025       my $query = qq|UPDATE shipto set
2026                        shiptoname = ?,
2027                        shiptodepartment_1 = ?,
2028                        shiptodepartment_2 = ?,
2029                        shiptostreet = ?,
2030                        shiptozipcode = ?,
2031                        shiptocity = ?,
2032                        shiptocountry = ?,
2033                        shiptocontact = ?,
2034                        shiptocp_gender = ?,
2035                        shiptophone = ?,
2036                        shiptofax = ?,
2037                        shiptoemail = ?
2038                      WHERE shipto_id = ?|;
2039       do_query($self, $dbh, $query, @values, $self->{shipto_id});
2040     } else {
2041       my $query = qq|SELECT * FROM shipto
2042                      WHERE shiptoname = ? AND
2043                        shiptodepartment_1 = ? AND
2044                        shiptodepartment_2 = ? AND
2045                        shiptostreet = ? AND
2046                        shiptozipcode = ? AND
2047                        shiptocity = ? AND
2048                        shiptocountry = ? AND
2049                        shiptocontact = ? AND
2050                        shiptocp_gender = ? AND
2051                        shiptophone = ? AND
2052                        shiptofax = ? AND
2053                        shiptoemail = ? AND
2054                        module = ? AND
2055                        trans_id = ?|;
2056       my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2057       if(!$insert_check){
2058         $query =
2059           qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2060                                  shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2061                                  shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2062              VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2063         do_query($self, $dbh, $query, $id, @values, $module);
2064       }
2065     }
2066   }
2067
2068   $main::lxdebug->leave_sub();
2069 }
2070
2071 sub get_employee {
2072   $main::lxdebug->enter_sub();
2073
2074   my ($self, $dbh) = @_;
2075
2076   $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2077
2078   my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2079   ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2080   $self->{"employee_id"} *= 1;
2081
2082   $main::lxdebug->leave_sub();
2083 }
2084
2085 sub get_employee_data {
2086   $main::lxdebug->enter_sub();
2087
2088   my $self     = shift;
2089   my %params   = @_;
2090
2091   Common::check_params(\%params, qw(prefix));
2092   Common::check_params_x(\%params, qw(id));
2093
2094   if (!$params{id}) {
2095     $main::lxdebug->leave_sub();
2096     return;
2097   }
2098
2099   my $myconfig = \%main::myconfig;
2100   my $dbh      = $params{dbh} || $self->get_standard_dbh($myconfig);
2101
2102   my ($login)  = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2103
2104   if ($login) {
2105     my $user = User->new($login);
2106     map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2107
2108     $self->{$params{prefix} . '_login'}   = $login;
2109     $self->{$params{prefix} . '_name'}  ||= $login;
2110   }
2111
2112   $main::lxdebug->leave_sub();
2113 }
2114
2115 sub get_duedate {
2116   $main::lxdebug->enter_sub();
2117
2118   my ($self, $myconfig, $reference_date) = @_;
2119
2120   $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2121
2122   my $dbh         = $self->get_standard_dbh($myconfig);
2123   my $query       = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2124   my ($duedate)   = selectrow_query($self, $dbh, $query, $self->{payment_id});
2125
2126   $main::lxdebug->leave_sub();
2127
2128   return $duedate;
2129 }
2130
2131 sub _get_contacts {
2132   $main::lxdebug->enter_sub();
2133
2134   my ($self, $dbh, $id, $key) = @_;
2135
2136   $key = "all_contacts" unless ($key);
2137
2138   if (!$id) {
2139     $self->{$key} = [];
2140     $main::lxdebug->leave_sub();
2141     return;
2142   }
2143
2144   my $query =
2145     qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2146     qq|FROM contacts | .
2147     qq|WHERE cp_cv_id = ? | .
2148     qq|ORDER BY lower(cp_name)|;
2149
2150   $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2151
2152   $main::lxdebug->leave_sub();
2153 }
2154
2155 sub _get_projects {
2156   $main::lxdebug->enter_sub();
2157
2158   my ($self, $dbh, $key) = @_;
2159
2160   my ($all, $old_id, $where, @values);
2161
2162   if (ref($key) eq "HASH") {
2163     my $params = $key;
2164
2165     $key = "ALL_PROJECTS";
2166
2167     foreach my $p (keys(%{$params})) {
2168       if ($p eq "all") {
2169         $all = $params->{$p};
2170       } elsif ($p eq "old_id") {
2171         $old_id = $params->{$p};
2172       } elsif ($p eq "key") {
2173         $key = $params->{$p};
2174       }
2175     }
2176   }
2177
2178   if (!$all) {
2179     $where = "WHERE active ";
2180     if ($old_id) {
2181       if (ref($old_id) eq "ARRAY") {
2182         my @ids = grep({ $_ } @{$old_id});
2183         if (@ids) {
2184           $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2185           push(@values, @ids);
2186         }
2187       } else {
2188         $where .= " OR (id = ?) ";
2189         push(@values, $old_id);
2190       }
2191     }
2192   }
2193
2194   my $query =
2195     qq|SELECT id, projectnumber, description, active | .
2196     qq|FROM project | .
2197     $where .
2198     qq|ORDER BY lower(projectnumber)|;
2199
2200   $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2201
2202   $main::lxdebug->leave_sub();
2203 }
2204
2205 sub _get_shipto {
2206   $main::lxdebug->enter_sub();
2207
2208   my ($self, $dbh, $vc_id, $key) = @_;
2209
2210   $key = "all_shipto" unless ($key);
2211
2212   if ($vc_id) {
2213     # get shipping addresses
2214     my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2215
2216     $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2217
2218   } else {
2219     $self->{$key} = [];
2220   }
2221
2222   $main::lxdebug->leave_sub();
2223 }
2224
2225 sub _get_printers {
2226   $main::lxdebug->enter_sub();
2227
2228   my ($self, $dbh, $key) = @_;
2229
2230   $key = "all_printers" unless ($key);
2231
2232   my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2233
2234   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2235
2236   $main::lxdebug->leave_sub();
2237 }
2238
2239 sub _get_charts {
2240   $main::lxdebug->enter_sub();
2241
2242   my ($self, $dbh, $params) = @_;
2243   my ($key);
2244
2245   $key = $params->{key};
2246   $key = "all_charts" unless ($key);
2247
2248   my $transdate = quote_db_date($params->{transdate});
2249
2250   my $query =
2251     qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2252     qq|FROM chart c | .
2253     qq|LEFT JOIN taxkeys tk ON | .
2254     qq|(tk.id = (SELECT id FROM taxkeys | .
2255     qq|          WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2256     qq|          ORDER BY startdate DESC LIMIT 1)) | .
2257     qq|ORDER BY c.accno|;
2258
2259   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2260
2261   $main::lxdebug->leave_sub();
2262 }
2263
2264 sub _get_taxcharts {
2265   $main::lxdebug->enter_sub();
2266
2267   my ($self, $dbh, $params) = @_;
2268
2269   my $key = "all_taxcharts";
2270   my @where;
2271
2272   if (ref $params eq 'HASH') {
2273     $key = $params->{key} if ($params->{key});
2274     if ($params->{module} eq 'AR') {
2275       push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2276
2277     } elsif ($params->{module} eq 'AP') {
2278       push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2279     }
2280
2281   } elsif ($params) {
2282     $key = $params;
2283   }
2284
2285   my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2286
2287   my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2288
2289   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2290
2291   $main::lxdebug->leave_sub();
2292 }
2293
2294 sub _get_taxzones {
2295   $main::lxdebug->enter_sub();
2296
2297   my ($self, $dbh, $key) = @_;
2298
2299   $key = "all_taxzones" unless ($key);
2300
2301   my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2302
2303   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2304
2305   $main::lxdebug->leave_sub();
2306 }
2307
2308 sub _get_employees {
2309   $main::lxdebug->enter_sub();
2310
2311   my ($self, $dbh, $default_key, $key) = @_;
2312
2313   $key = $default_key unless ($key);
2314   $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2315
2316   $main::lxdebug->leave_sub();
2317 }
2318
2319 sub _get_business_types {
2320   $main::lxdebug->enter_sub();
2321
2322   my ($self, $dbh, $key) = @_;
2323
2324   my $options       = ref $key eq 'HASH' ? $key : { key => $key };
2325   $options->{key} ||= "all_business_types";
2326   my $where         = '';
2327
2328   if (exists $options->{salesman}) {
2329     $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2330   }
2331
2332   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2333
2334   $main::lxdebug->leave_sub();
2335 }
2336
2337 sub _get_languages {
2338   $main::lxdebug->enter_sub();
2339
2340   my ($self, $dbh, $key) = @_;
2341
2342   $key = "all_languages" unless ($key);
2343
2344   my $query = qq|SELECT * FROM language ORDER BY id|;
2345
2346   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2347
2348   $main::lxdebug->leave_sub();
2349 }
2350
2351 sub _get_dunning_configs {
2352   $main::lxdebug->enter_sub();
2353
2354   my ($self, $dbh, $key) = @_;
2355
2356   $key = "all_dunning_configs" unless ($key);
2357
2358   my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2359
2360   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2361
2362   $main::lxdebug->leave_sub();
2363 }
2364
2365 sub _get_currencies {
2366 $main::lxdebug->enter_sub();
2367
2368   my ($self, $dbh, $key) = @_;
2369
2370   $key = "all_currencies" unless ($key);
2371
2372   my $query = qq|SELECT curr AS currency FROM defaults|;
2373
2374   $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2375
2376   $main::lxdebug->leave_sub();
2377 }
2378
2379 sub _get_payments {
2380 $main::lxdebug->enter_sub();
2381
2382   my ($self, $dbh, $key) = @_;
2383
2384   $key = "all_payments" unless ($key);
2385
2386   my $query = qq|SELECT * FROM payment_terms ORDER BY sortkey|;
2387
2388   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2389
2390   $main::lxdebug->leave_sub();
2391 }
2392
2393 sub _get_customers {
2394   $main::lxdebug->enter_sub();
2395
2396   my ($self, $dbh, $key) = @_;
2397
2398   my $options        = ref $key eq 'HASH' ? $key : { key => $key };
2399   $options->{key}  ||= "all_customers";
2400   my $limit_clause   = "LIMIT $options->{limit}" if $options->{limit};
2401
2402   my @where;
2403   push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if  $options->{business_is_salesman};
2404   push @where, qq|NOT obsolete|                                            if !$options->{with_obsolete};
2405   my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2406
2407   my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2408   $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2409
2410   $main::lxdebug->leave_sub();
2411 }
2412
2413 sub _get_vendors {
2414   $main::lxdebug->enter_sub();
2415
2416   my ($self, $dbh, $key) = @_;
2417
2418   $key = "all_vendors" unless ($key);
2419
2420   my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2421
2422   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2423
2424   $main::lxdebug->leave_sub();
2425 }
2426
2427 sub _get_departments {
2428   $main::lxdebug->enter_sub();
2429
2430   my ($self, $dbh, $key) = @_;
2431
2432   $key = "all_departments" unless ($key);
2433
2434   my $query = qq|SELECT * FROM department ORDER BY description|;
2435
2436   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2437
2438   $main::lxdebug->leave_sub();
2439 }
2440
2441 sub _get_warehouses {
2442   $main::lxdebug->enter_sub();
2443
2444   my ($self, $dbh, $param) = @_;
2445
2446   my ($key, $bins_key);
2447
2448   if ('' eq ref $param) {
2449     $key = $param;
2450
2451   } else {
2452     $key      = $param->{key};
2453     $bins_key = $param->{bins};
2454   }
2455
2456   my $query = qq|SELECT w.* FROM warehouse w
2457                  WHERE (NOT w.invalid) AND
2458                    ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2459                  ORDER BY w.sortkey|;
2460
2461   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2462
2463   if ($bins_key) {
2464     $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?
2465                 ORDER BY description|;
2466     my $sth = prepare_query($self, $dbh, $query);
2467
2468     foreach my $warehouse (@{ $self->{$key} }) {
2469       do_statement($self, $sth, $query, $warehouse->{id});
2470       $warehouse->{$bins_key} = [];
2471
2472       while (my $ref = $sth->fetchrow_hashref()) {
2473         push @{ $warehouse->{$bins_key} }, $ref;
2474       }
2475     }
2476     $sth->finish();
2477   }
2478
2479   $main::lxdebug->leave_sub();
2480 }
2481
2482 sub _get_simple {
2483   $main::lxdebug->enter_sub();
2484
2485   my ($self, $dbh, $table, $key, $sortkey) = @_;
2486
2487   my $query  = qq|SELECT * FROM $table|;
2488   $query    .= qq| ORDER BY $sortkey| if ($sortkey);
2489
2490   $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2491
2492   $main::lxdebug->leave_sub();
2493 }
2494
2495 #sub _get_groups {
2496 #  $main::lxdebug->enter_sub();
2497 #
2498 #  my ($self, $dbh, $key) = @_;
2499 #
2500 #  $key ||= "all_groups";
2501 #
2502 #  my $groups = $main::auth->read_groups();
2503 #
2504 #  $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2505 #
2506 #  $main::lxdebug->leave_sub();
2507 #}
2508
2509 sub get_lists {
2510   $main::lxdebug->enter_sub();
2511
2512   my $self = shift;
2513   my %params = @_;
2514
2515   my $dbh = $self->get_standard_dbh(\%main::myconfig);
2516   my ($sth, $query, $ref);
2517
2518   my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2519   my $vc_id = $self->{"${vc}_id"};
2520
2521   if ($params{"contacts"}) {
2522     $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2523   }
2524
2525   if ($params{"shipto"}) {
2526     $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2527   }
2528
2529   if ($params{"projects"} || $params{"all_projects"}) {
2530     $self->_get_projects($dbh, $params{"all_projects"} ?
2531                          $params{"all_projects"} : $params{"projects"},
2532                          $params{"all_projects"} ? 1 : 0);
2533   }
2534
2535   if ($params{"printers"}) {
2536     $self->_get_printers($dbh, $params{"printers"});
2537   }
2538
2539   if ($params{"languages"}) {
2540     $self->_get_languages($dbh, $params{"languages"});
2541   }
2542
2543   if ($params{"charts"}) {
2544     $self->_get_charts($dbh, $params{"charts"});
2545   }
2546
2547   if ($params{"taxcharts"}) {
2548     $self->_get_taxcharts($dbh, $params{"taxcharts"});
2549   }
2550
2551   if ($params{"taxzones"}) {
2552     $self->_get_taxzones($dbh, $params{"taxzones"});
2553   }
2554
2555   if ($params{"employees"}) {
2556     $self->_get_employees($dbh, "all_employees", $params{"employees"});
2557   }
2558
2559   if ($params{"salesmen"}) {
2560     $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2561   }
2562
2563   if ($params{"business_types"}) {
2564     $self->_get_business_types($dbh, $params{"business_types"});
2565   }
2566
2567   if ($params{"dunning_configs"}) {
2568     $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2569   }
2570
2571   if($params{"currencies"}) {
2572     $self->_get_currencies($dbh, $params{"currencies"});
2573   }
2574
2575   if($params{"customers"}) {
2576     $self->_get_customers($dbh, $params{"customers"});
2577   }
2578
2579   if($params{"vendors"}) {
2580     if (ref $params{"vendors"} eq 'HASH') {
2581       $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2582     } else {
2583       $self->_get_vendors($dbh, $params{"vendors"});
2584     }
2585   }
2586
2587   if($params{"payments"}) {
2588     $self->_get_payments($dbh, $params{"payments"});
2589   }
2590
2591   if($params{"departments"}) {
2592     $self->_get_departments($dbh, $params{"departments"});
2593   }
2594
2595   if ($params{price_factors}) {
2596     $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2597   }
2598
2599   if ($params{warehouses}) {
2600     $self->_get_warehouses($dbh, $params{warehouses});
2601   }
2602
2603 #  if ($params{groups}) {
2604 #    $self->_get_groups($dbh, $params{groups});
2605 #  }
2606
2607   if ($params{partsgroup}) {
2608     $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2609   }
2610
2611   $main::lxdebug->leave_sub();
2612 }
2613
2614 # this sub gets the id and name from $table
2615 sub get_name {
2616   $main::lxdebug->enter_sub();
2617
2618   my ($self, $myconfig, $table) = @_;
2619
2620   # connect to database
2621   my $dbh = $self->get_standard_dbh($myconfig);
2622
2623   $table = $table eq "customer" ? "customer" : "vendor";
2624   my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2625
2626   my ($query, @values);
2627
2628   if (!$self->{openinvoices}) {
2629     my $where;
2630     if ($self->{customernumber} ne "") {
2631       $where = qq|(vc.customernumber ILIKE ?)|;
2632       push(@values, '%' . $self->{customernumber} . '%');
2633     } else {
2634       $where = qq|(vc.name ILIKE ?)|;
2635       push(@values, '%' . $self->{$table} . '%');
2636     }
2637
2638     $query =
2639       qq~SELECT vc.id, vc.name,
2640            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2641          FROM $table vc
2642          WHERE $where AND (NOT vc.obsolete)
2643          ORDER BY vc.name~;
2644   } else {
2645     $query =
2646       qq~SELECT DISTINCT vc.id, vc.name,
2647            vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2648          FROM $arap a
2649          JOIN $table vc ON (a.${table}_id = vc.id)
2650          WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2651          ORDER BY vc.name~;
2652     push(@values, '%' . $self->{$table} . '%');
2653   }
2654
2655   $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2656
2657   $main::lxdebug->leave_sub();
2658
2659   return scalar(@{ $self->{name_list} });
2660 }
2661
2662 # the selection sub is used in the AR, AP, IS, IR and OE module
2663 #
2664 sub all_vc {
2665   $main::lxdebug->enter_sub();
2666
2667   my ($self, $myconfig, $table, $module) = @_;
2668
2669   my $ref;
2670   my $dbh = $self->get_standard_dbh;
2671
2672   $table = $table eq "customer" ? "customer" : "vendor";
2673
2674   my $query = qq|SELECT count(*) FROM $table|;
2675   my ($count) = selectrow_query($self, $dbh, $query);
2676
2677   # build selection list
2678   if ($count <= $myconfig->{vclimit}) {
2679     $query = qq|SELECT id, name, salesman_id
2680                 FROM $table WHERE NOT obsolete
2681                 ORDER BY name|;
2682     $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2683   }
2684
2685   # get self
2686   $self->get_employee($dbh);
2687
2688   # setup sales contacts
2689   $query = qq|SELECT e.id, e.name
2690               FROM employee e
2691               WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2692   $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2693
2694   # this is for self
2695   push(@{ $self->{all_employees} },
2696        { id   => $self->{employee_id},
2697          name => $self->{employee} });
2698
2699   # sort the whole thing
2700   @{ $self->{all_employees} } =
2701     sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2702
2703   if ($module eq 'AR') {
2704
2705     # prepare query for departments
2706     $query = qq|SELECT id, description
2707                 FROM department
2708                 WHERE role = 'P'
2709                 ORDER BY description|;
2710
2711   } else {
2712     $query = qq|SELECT id, description
2713                 FROM department
2714                 ORDER BY description|;
2715   }
2716
2717   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2718
2719   # get languages
2720   $query = qq|SELECT id, description
2721               FROM language
2722               ORDER BY id|;
2723
2724   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2725
2726   # get printer
2727   $query = qq|SELECT printer_description, id
2728               FROM printers
2729               ORDER BY printer_description|;
2730
2731   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2732
2733   # get payment terms
2734   $query = qq|SELECT id, description
2735               FROM payment_terms
2736               ORDER BY sortkey|;
2737
2738   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2739
2740   $main::lxdebug->leave_sub();
2741 }
2742
2743 sub language_payment {
2744   $main::lxdebug->enter_sub();
2745
2746   my ($self, $myconfig) = @_;
2747
2748   my $dbh = $self->get_standard_dbh($myconfig);
2749   # get languages
2750   my $query = qq|SELECT id, description
2751                  FROM language
2752                  ORDER BY id|;
2753
2754   $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2755
2756   # get printer
2757   $query = qq|SELECT printer_description, id
2758               FROM printers
2759               ORDER BY printer_description|;
2760
2761   $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2762
2763   # get payment terms
2764   $query = qq|SELECT id, description
2765               FROM payment_terms
2766               ORDER BY sortkey|;
2767
2768   $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2769
2770   # get buchungsgruppen
2771   $query = qq|SELECT id, description
2772               FROM buchungsgruppen|;
2773
2774   $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2775
2776   $main::lxdebug->leave_sub();
2777 }
2778
2779 # this is only used for reports
2780 sub all_departments {
2781   $main::lxdebug->enter_sub();
2782
2783   my ($self, $myconfig, $table) = @_;
2784
2785   my $dbh = $self->get_standard_dbh($myconfig);
2786   my $where;
2787
2788   if ($table eq 'customer') {
2789     $where = "WHERE role = 'P' ";
2790   }
2791
2792   my $query = qq|SELECT id, description
2793                  FROM department
2794                  $where
2795                  ORDER BY description|;
2796   $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2797
2798   delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2799
2800   $main::lxdebug->leave_sub();
2801 }
2802
2803 sub create_links {
2804   $main::lxdebug->enter_sub();
2805
2806   my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2807
2808   my ($fld, $arap);
2809   if ($table eq "customer") {
2810     $fld = "buy";
2811     $arap = "ar";
2812   } else {
2813     $table = "vendor";
2814     $fld = "sell";
2815     $arap = "ap";
2816   }
2817
2818   $self->all_vc($myconfig, $table, $module);
2819
2820   # get last customers or vendors
2821   my ($query, $sth, $ref);
2822
2823   my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2824   my %xkeyref = ();
2825
2826   if (!$self->{id}) {
2827
2828     my $transdate = "current_date";
2829     if ($self->{transdate}) {
2830       $transdate = $dbh->quote($self->{transdate});
2831     }
2832
2833     # now get the account numbers
2834     $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2835                 FROM chart c, taxkeys tk
2836                 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2837                   (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2838                 ORDER BY c.accno|;
2839
2840     $sth = $dbh->prepare($query);
2841
2842     do_statement($self, $sth, $query, '%' . $module . '%');
2843
2844     $self->{accounts} = "";
2845     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2846
2847       foreach my $key (split(/:/, $ref->{link})) {
2848         if ($key =~ /\Q$module\E/) {
2849
2850           # cross reference for keys
2851           $xkeyref{ $ref->{accno} } = $key;
2852
2853           push @{ $self->{"${module}_links"}{$key} },
2854             { accno       => $ref->{accno},
2855               description => $ref->{description},
2856               taxkey      => $ref->{taxkey_id},
2857               tax_id      => $ref->{tax_id} };
2858
2859           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2860         }
2861       }
2862     }
2863   }
2864
2865   # get taxkeys and description
2866   $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2867   $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2868
2869   if (($module eq "AP") || ($module eq "AR")) {
2870     # get tax rates and description
2871     $query = qq|SELECT * FROM tax|;
2872     $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2873   }
2874
2875   if ($self->{id}) {
2876     $query =
2877       qq|SELECT
2878            a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2879            a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2880            a.intnotes, a.department_id, a.amount AS oldinvtotal,
2881            a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2882            c.name AS $table,
2883            d.description AS department,
2884            e.name AS employee
2885          FROM $arap a
2886          JOIN $table c ON (a.${table}_id = c.id)
2887          LEFT JOIN employee e ON (e.id = a.employee_id)
2888          LEFT JOIN department d ON (d.id = a.department_id)
2889          WHERE a.id = ?|;
2890     $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2891
2892     foreach my $key (keys %$ref) {
2893       $self->{$key} = $ref->{$key};
2894     }
2895
2896     my $transdate = "current_date";
2897     if ($self->{transdate}) {
2898       $transdate = $dbh->quote($self->{transdate});
2899     }
2900
2901     # now get the account numbers
2902     $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2903                 FROM chart c
2904                 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2905                 WHERE c.link LIKE ?
2906                   AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2907                     OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2908                 ORDER BY c.accno|;
2909
2910     $sth = $dbh->prepare($query);
2911     do_statement($self, $sth, $query, "%$module%");
2912
2913     $self->{accounts} = "";
2914     while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2915
2916       foreach my $key (split(/:/, $ref->{link})) {
2917         if ($key =~ /\Q$module\E/) {
2918
2919           # cross reference for keys
2920           $xkeyref{ $ref->{accno} } = $key;
2921
2922           push @{ $self->{"${module}_links"}{$key} },
2923             { accno       => $ref->{accno},
2924               description => $ref->{description},
2925               taxkey      => $ref->{taxkey_id},
2926               tax_id      => $ref->{tax_id} };
2927
2928           $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2929         }
2930       }
2931     }
2932
2933
2934     # get amounts from individual entries
2935     $query =
2936       qq|SELECT
2937            c.accno, c.description,
2938            a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2939            p.projectnumber,
2940            t.rate, t.id
2941          FROM acc_trans a
2942          LEFT JOIN chart c ON (c.id = a.chart_id)
2943          LEFT JOIN project p ON (p.id = a.project_id)
2944          LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2945                                     WHERE (tk.taxkey_id=a.taxkey) AND
2946                                       ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2947                                         THEN tk.chart_id = a.chart_id
2948                                         ELSE 1 = 1
2949                                         END)
2950                                        OR (c.link='%tax%')) AND
2951                                       (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2952          WHERE a.trans_id = ?
2953          AND a.fx_transaction = '0'
2954          ORDER BY a.acc_trans_id, a.transdate|;
2955     $sth = $dbh->prepare($query);
2956     do_statement($self, $sth, $query, $self->{id});
2957
2958     # get exchangerate for currency
2959     $self->{exchangerate} =
2960       $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2961     my $index = 0;
2962
2963     # store amounts in {acc_trans}{$key} for multiple accounts
2964     while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2965       $ref->{exchangerate} =
2966         $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2967       if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2968         $index++;
2969       }
2970       if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2971         $ref->{amount} *= -1;
2972       }
2973       $ref->{index} = $index;
2974
2975       push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2976     }
2977
2978     $sth->finish;
2979     $query =
2980       qq|SELECT
2981            d.curr AS currencies, d.closedto, d.revtrans,
2982            (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2983            (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2984          FROM defaults d|;
2985     $ref = selectfirst_hashref_query($self, $dbh, $query);
2986     map { $self->{$_} = $ref->{$_} } keys %$ref;
2987
2988   } else {
2989
2990     # get date
2991     $query =
2992        qq|SELECT
2993             current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2994             (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2995             (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2996           FROM defaults d|;
2997     $ref = selectfirst_hashref_query($self, $dbh, $query);
2998     map { $self->{$_} = $ref->{$_} } keys %$ref;
2999
3000     if ($self->{"$self->{vc}_id"}) {
3001
3002       # only setup currency
3003       ($self->{currency}) = split(/:/, $self->{currencies});
3004
3005     } else {
3006
3007       $self->lastname_used($dbh, $myconfig, $table, $module);
3008
3009       # get exchangerate for currency
3010       $self->{exchangerate} =
3011         $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3012
3013     }
3014
3015   }
3016
3017   $main::lxdebug->leave_sub();
3018 }
3019
3020 sub lastname_used {
3021   $main::lxdebug->enter_sub();
3022
3023   my ($self, $dbh, $myconfig, $table, $module) = @_;
3024
3025   my ($arap, $where);
3026
3027   $table         = $table eq "customer" ? "customer" : "vendor";
3028   my %column_map = ("a.curr"                  => "currency",
3029                     "a.${table}_id"           => "${table}_id",
3030                     "a.department_id"         => "department_id",
3031                     "d.description"           => "department",
3032                     "ct.name"                 => $table,
3033                     "current_date + ct.terms" => "duedate",
3034     );
3035
3036   if ($self->{type} =~ /delivery_order/) {
3037     $arap  = 'delivery_orders';
3038     delete $column_map{"a.curr"};
3039
3040   } elsif ($self->{type} =~ /_order/) {
3041     $arap  = 'oe';
3042     $where = "quotation = '0'";
3043
3044   } elsif ($self->{type} =~ /_quotation/) {
3045     $arap  = 'oe';
3046     $where = "quotation = '1'";
3047
3048   } elsif ($table eq 'customer') {
3049     $arap  = 'ar';
3050
3051   } else {
3052     $arap  = 'ap';
3053
3054   }
3055
3056   $where           = "($where) AND" if ($where);
3057   my $query        = qq|SELECT MAX(id) FROM $arap
3058                         WHERE $where ${table}_id > 0|;
3059   my ($trans_id)   = selectrow_query($self, $dbh, $query);
3060   $trans_id       *= 1;
3061
3062   my $column_spec  = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3063   $query           = qq|SELECT $column_spec
3064                         FROM $arap a
3065                         LEFT JOIN $table     ct ON (a.${table}_id = ct.id)
3066                         LEFT JOIN department d  ON (a.department_id = d.id)
3067                         WHERE a.id = ?|;
3068   my $ref          = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3069
3070   map { $self->{$_} = $ref->{$_} } values %column_map;
3071
3072   $main::lxdebug->leave_sub();
3073 }
3074
3075 sub current_date {
3076   $main::lxdebug->enter_sub();
3077
3078   my $self     = shift;
3079   my $myconfig = shift || \%::myconfig;
3080   my ($thisdate, $days) = @_;
3081
3082   my $dbh = $self->get_standard_dbh($myconfig);
3083   my $query;
3084
3085   $days *= 1;
3086   if ($thisdate) {
3087     my $dateformat = $myconfig->{dateformat};
3088     $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3089     $thisdate = $dbh->quote($thisdate);
3090     $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3091   } else {
3092     $query = qq|SELECT current_date AS thisdate|;
3093   }
3094
3095   ($thisdate) = selectrow_query($self, $dbh, $query);
3096
3097   $main::lxdebug->leave_sub();
3098
3099   return $thisdate;
3100 }
3101
3102 sub like {
3103   $main::lxdebug->enter_sub();
3104
3105   my ($self, $string) = @_;
3106
3107   if ($string !~ /%/) {
3108     $string = "%$string%";
3109   }
3110
3111   $string =~ s/\'/\'\'/g;
3112
3113   $main::lxdebug->leave_sub();
3114
3115   return $string;
3116 }
3117
3118 sub redo_rows {
3119   $main::lxdebug->enter_sub();
3120
3121   my ($self, $flds, $new, $count, $numrows) = @_;
3122
3123   my @ndx = ();
3124
3125   map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3126
3127   my $i = 0;
3128
3129   # fill rows
3130   foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3131     $i++;
3132     my $j = $item->{ndx} - 1;
3133     map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3134   }
3135
3136   # delete empty rows
3137   for $i ($count + 1 .. $numrows) {
3138     map { delete $self->{"${_}_$i"} } @{$flds};
3139   }
3140
3141   $main::lxdebug->leave_sub();
3142 }
3143
3144 sub update_status {
3145   $main::lxdebug->enter_sub();
3146
3147   my ($self, $myconfig) = @_;
3148
3149   my ($i, $id);
3150
3151   my $dbh = $self->dbconnect_noauto($myconfig);
3152
3153   my $query = qq|DELETE FROM status
3154                  WHERE (formname = ?) AND (trans_id = ?)|;
3155   my $sth = prepare_query($self, $dbh, $query);
3156
3157   if ($self->{formname} =~ /(check|receipt)/) {
3158     for $i (1 .. $self->{rowcount}) {
3159       do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3160     }
3161   } else {
3162     do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3163   }
3164   $sth->finish();
3165
3166   my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3167   my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3168
3169   my %queued = split / /, $self->{queued};
3170   my @values;
3171
3172   if ($self->{formname} =~ /(check|receipt)/) {
3173
3174     # this is a check or receipt, add one entry for each lineitem
3175     my ($accno) = split /--/, $self->{account};
3176     $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3177                 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3178     @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3179     $sth = prepare_query($self, $dbh, $query);
3180
3181     for $i (1 .. $self->{rowcount}) {
3182       if ($self->{"checked_$i"}) {
3183         do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3184       }
3185     }
3186     $sth->finish();
3187
3188   } else {
3189     $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3190                 VALUES (?, ?, ?, ?, ?)|;
3191     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3192              $queued{$self->{formname}}, $self->{formname});
3193   }
3194
3195   $dbh->commit;
3196   $dbh->disconnect;
3197
3198   $main::lxdebug->leave_sub();
3199 }
3200
3201 sub save_status {
3202   $main::lxdebug->enter_sub();
3203
3204   my ($self, $dbh) = @_;
3205
3206   my ($query, $printed, $emailed);
3207
3208   my $formnames  = $self->{printed};
3209   my $emailforms = $self->{emailed};
3210
3211   $query = qq|DELETE FROM status
3212                  WHERE (formname = ?) AND (trans_id = ?)|;
3213   do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3214
3215   # this only applies to the forms
3216   # checks and receipts are posted when printed or queued
3217
3218   if ($self->{queued}) {
3219     my %queued = split / /, $self->{queued};
3220
3221     foreach my $formname (keys %queued) {
3222       $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3223       $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3224
3225       $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3226                   VALUES (?, ?, ?, ?, ?)|;
3227       do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3228
3229       $formnames  =~ s/\Q$self->{formname}\E//;
3230       $emailforms =~ s/\Q$self->{formname}\E//;
3231
3232     }
3233   }
3234
3235   # save printed, emailed info
3236   $formnames  =~ s/^ +//g;
3237   $emailforms =~ s/^ +//g;
3238
3239   my %status = ();
3240   map { $status{$_}{printed} = 1 } split / +/, $formnames;
3241   map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3242
3243   foreach my $formname (keys %status) {
3244     $printed = ($formnames  =~ /\Q$self->{formname}\E/) ? "1" : "0";
3245     $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3246
3247     $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3248                 VALUES (?, ?, ?, ?)|;
3249     do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3250   }
3251
3252   $main::lxdebug->leave_sub();
3253 }
3254
3255 #--- 4 locale ---#
3256 # $main::locale->text('SAVED')
3257 # $main::locale->text('DELETED')
3258 # $main::locale->text('ADDED')
3259 # $main::locale->text('PAYMENT POSTED')
3260 # $main::locale->text('POSTED')
3261 # $main::locale->text('POSTED AS NEW')
3262 # $main::locale->text('ELSE')
3263 # $main::locale->text('SAVED FOR DUNNING')
3264 # $main::locale->text('DUNNING STARTED')
3265 # $main::locale->text('PRINTED')
3266 # $main::locale->text('MAILED')
3267 # $main::locale->text('SCREENED')
3268 # $main::locale->text('CANCELED')
3269 # $main::locale->text('invoice')
3270 # $main::locale->text('proforma')
3271 # $main::locale->text('sales_order')
3272 # $main::locale->text('pick_list')
3273 # $main::locale->text('purchase_order')
3274 # $main::locale->text('bin_list')
3275 # $main::locale->text('sales_quotation')
3276 # $main::locale->text('request_quotation')
3277
3278 sub save_history {
3279   $main::lxdebug->enter_sub();
3280
3281   my $self = shift;
3282   my $dbh  = shift || $self->get_standard_dbh;
3283
3284   if(!exists $self->{employee_id}) {
3285     &get_employee($self, $dbh);
3286   }
3287
3288   my $query =
3289    qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3290    qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3291   my @values = (conv_i($self->{id}), $self->{login},
3292                 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3293   do_query($self, $dbh, $query, @values);
3294
3295   $dbh->commit;
3296
3297   $main::lxdebug->leave_sub();
3298 }
3299
3300 sub get_history {
3301   $main::lxdebug->enter_sub();
3302
3303   my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3304   my ($orderBy, $desc) = split(/\-\-/, $order);
3305   $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3306   my @tempArray;
3307   my $i = 0;
3308   if ($trans_id ne "") {
3309     my $query =
3310       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 | .
3311       qq|FROM history_erp h | .
3312       qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3313       qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3314       $order;
3315
3316     my $sth = $dbh->prepare($query) || $self->dberror($query);
3317
3318     $sth->execute() || $self->dberror("$query");
3319
3320     while(my $hash_ref = $sth->fetchrow_hashref()) {
3321       $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3322       $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3323       $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3324       $tempArray[$i++] = $hash_ref;
3325     }
3326     $main::lxdebug->leave_sub() and return \@tempArray
3327       if ($i > 0 && $tempArray[0] ne "");
3328   }
3329   $main::lxdebug->leave_sub();
3330   return 0;
3331 }
3332
3333 sub update_defaults {
3334   $main::lxdebug->enter_sub();
3335
3336   my ($self, $myconfig, $fld, $provided_dbh) = @_;
3337
3338   my $dbh;
3339   if ($provided_dbh) {
3340     $dbh = $provided_dbh;
3341   } else {
3342     $dbh = $self->dbconnect_noauto($myconfig);
3343   }
3344   my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3345   my $sth   = $dbh->prepare($query);
3346
3347   $sth->execute || $self->dberror($query);
3348   my ($var) = $sth->fetchrow_array;
3349   $sth->finish;
3350
3351   if ($var =~ m/\d+$/) {
3352     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3353     my $len_diff = length($var) - $-[0] - length($new_var);
3354     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3355
3356   } else {
3357     $var = $var . '1';
3358   }
3359
3360   $query = qq|UPDATE defaults SET $fld = ?|;
3361   do_query($self, $dbh, $query, $var);
3362
3363   if (!$provided_dbh) {
3364     $dbh->commit;
3365     $dbh->disconnect;
3366   }
3367
3368   $main::lxdebug->leave_sub();
3369
3370   return $var;
3371 }
3372
3373 sub update_business {
3374   $main::lxdebug->enter_sub();
3375
3376   my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3377
3378   my $dbh;
3379   if ($provided_dbh) {
3380     $dbh = $provided_dbh;
3381   } else {
3382     $dbh = $self->dbconnect_noauto($myconfig);
3383   }
3384   my $query =
3385     qq|SELECT customernumberinit FROM business
3386        WHERE id = ? FOR UPDATE|;
3387   my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3388
3389   return undef unless $var;
3390
3391   if ($var =~ m/\d+$/) {
3392     my $new_var  = (substr $var, $-[0]) * 1 + 1;
3393     my $len_diff = length($var) - $-[0] - length($new_var);
3394     $var         = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3395
3396   } else {
3397     $var = $var . '1';
3398   }
3399
3400   $query = qq|UPDATE business
3401               SET customernumberinit = ?
3402               WHERE id = ?|;
3403   do_query($self, $dbh, $query, $var, $business_id);
3404
3405   if (!$provided_dbh) {
3406     $dbh->commit;
3407     $dbh->disconnect;
3408   }
3409
3410   $main::lxdebug->leave_sub();
3411
3412   return $var;
3413 }
3414
3415 sub get_partsgroup {
3416   $main::lxdebug->enter_sub();
3417
3418   my ($self, $myconfig, $p) = @_;
3419   my $target = $p->{target} || 'all_partsgroup';
3420
3421   my $dbh = $self->get_standard_dbh($myconfig);
3422
3423   my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3424                  FROM partsgroup pg
3425                  JOIN parts p ON (p.partsgroup_id = pg.id) |;
3426   my @values;
3427
3428   if ($p->{searchitems} eq 'part') {
3429     $query .= qq|WHERE p.inventory_accno_id > 0|;
3430   }
3431   if ($p->{searchitems} eq 'service') {
3432     $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3433   }
3434   if ($p->{searchitems} eq 'assembly') {
3435     $query .= qq|WHERE p.assembly = '1'|;
3436   }
3437   if ($p->{searchitems} eq 'labor') {
3438     $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3439   }
3440
3441   $query .= qq|ORDER BY partsgroup|;
3442
3443   if ($p->{all}) {
3444     $query = qq|SELECT id, partsgroup FROM partsgroup
3445                 ORDER BY partsgroup|;
3446   }
3447
3448   if ($p->{language_code}) {
3449     $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3450                   t.description AS translation
3451                 FROM partsgroup pg
3452                 JOIN parts p ON (p.partsgroup_id = pg.id)
3453                 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3454                 ORDER BY translation|;
3455     @values = ($p->{language_code});
3456   }
3457
3458   $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3459
3460   $main::lxdebug->leave_sub();
3461 }
3462
3463 sub get_pricegroup {
3464   $main::lxdebug->enter_sub();
3465
3466   my ($self, $myconfig, $p) = @_;
3467
3468   my $dbh = $self->get_standard_dbh($myconfig);
3469
3470   my $query = qq|SELECT p.id, p.pricegroup
3471                  FROM pricegroup p|;
3472
3473   $query .= qq| ORDER BY pricegroup|;
3474
3475   if ($p->{all}) {
3476     $query = qq|SELECT id, pricegroup FROM pricegroup
3477                 ORDER BY pricegroup|;
3478   }
3479
3480   $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3481
3482   $main::lxdebug->leave_sub();
3483 }
3484
3485 sub all_years {
3486 # usage $form->all_years($myconfig, [$dbh])
3487 # return list of all years where bookings found
3488 # (@all_years)
3489
3490   $main::lxdebug->enter_sub();
3491
3492   my ($self, $myconfig, $dbh) = @_;
3493
3494   $dbh ||= $self->get_standard_dbh($myconfig);
3495
3496   # get years
3497   my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3498                    (SELECT MAX(transdate) FROM acc_trans)|;
3499   my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3500
3501   if ($myconfig->{dateformat} =~ /^yy/) {
3502     ($startdate) = split /\W/, $startdate;
3503     ($enddate) = split /\W/, $enddate;
3504   } else {
3505     (@_) = split /\W/, $startdate;
3506     $startdate = $_[2];
3507     (@_) = split /\W/, $enddate;
3508     $enddate = $_[2];
3509   }
3510
3511   my @all_years;
3512   $startdate = substr($startdate,0,4);
3513   $enddate = substr($enddate,0,4);
3514
3515   while ($enddate >= $startdate) {
3516     push @all_years, $enddate--;
3517   }
3518
3519   return @all_years;
3520
3521   $main::lxdebug->leave_sub();
3522 }
3523
3524 sub backup_vars {
3525   $main::lxdebug->enter_sub();
3526   my $self = shift;
3527   my @vars = @_;
3528
3529   map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3530
3531   $main::lxdebug->leave_sub();
3532 }
3533
3534 sub restore_vars {
3535   $main::lxdebug->enter_sub();
3536
3537   my $self = shift;
3538   my @vars = @_;
3539
3540   map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3541
3542   $main::lxdebug->leave_sub();
3543 }
3544
3545 sub prepare_for_printing {
3546   my ($self) = @_;
3547
3548   $self->{templates} ||= $::myconfig{templates};
3549   $self->{formname}  ||= $self->{type};
3550   $self->{media}     ||= 'email';
3551
3552   die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3553
3554   # set shipto from billto unless set
3555   my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3556   if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3557     $self->{shiptoname}   = $::myconfig{company};
3558     $self->{shiptostreet} = $::myconfig{address};
3559   }
3560
3561   my $language = $self->{language} ? '_' . $self->{language} : '';
3562
3563   my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3564   if ($self->{language_id}) {
3565     ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3566   } else {
3567     $output_dateformat   = $::myconfig{dateformat};
3568     $output_numberformat = $::myconfig{numberformat};
3569     $output_longdates    = 1;
3570   }
3571
3572   # Retrieve accounts for tax calculation.
3573   IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3574
3575   if ($self->{type} =~ /_delivery_order$/) {
3576     DO->order_details();
3577   } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3578     OE->order_details(\%::myconfig, $self);
3579   } else {
3580     IS->invoice_details(\%::myconfig, $self, $::locale);
3581   }
3582
3583   # Chose extension & set source file name
3584   my $extension = 'html';
3585   if ($self->{format} eq 'postscript') {
3586     $self->{postscript}   = 1;
3587     $extension            = 'tex';
3588   } elsif ($self->{"format"} =~ /pdf/) {
3589     $self->{pdf}          = 1;
3590     $extension            = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3591   } elsif ($self->{"format"} =~ /opendocument/) {
3592     $self->{opendocument} = 1;
3593     $extension            = 'odt';
3594   } elsif ($self->{"format"} =~ /excel/) {
3595     $self->{excel}        = 1;
3596     $extension            = 'xls';
3597   }
3598
3599   my $printer_code    = '_' . $self->{printer_code} if $self->{printer_code};
3600   my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3601   $self->{IN}         = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3602
3603   # Format dates.
3604   $self->format_dates($output_dateformat, $output_longdates,
3605                       qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3606                          transdate_oe deliverydate_oe employee_startdate employee_enddate),
3607                       grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3608
3609   $self->reformat_numbers($output_numberformat, 2,
3610                           qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3611                           grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3612
3613   $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3614
3615   my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3616
3617   if (scalar @{ $cvar_date_fields }) {
3618     $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3619   }
3620
3621   while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3622     $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3623   }
3624
3625   return $self;
3626 }
3627
3628 sub format_dates {
3629   my ($self, $dateformat, $longformat, @indices) = @_;
3630
3631   $dateformat ||= $::myconfig{dateformat};
3632
3633   foreach my $idx (@indices) {
3634     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3635       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3636         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3637       }
3638     }
3639
3640     next unless defined $self->{$idx};
3641
3642     if (!ref($self->{$idx})) {
3643       $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3644
3645     } elsif (ref($self->{$idx}) eq "ARRAY") {
3646       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3647         $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3648       }
3649     }
3650   }
3651 }
3652
3653 sub reformat_numbers {
3654   my ($self, $numberformat, $places, @indices) = @_;
3655
3656   return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3657
3658   foreach my $idx (@indices) {
3659     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3660       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3661         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3662       }
3663     }
3664
3665     next unless defined $self->{$idx};
3666
3667     if (!ref($self->{$idx})) {
3668       $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3669
3670     } elsif (ref($self->{$idx}) eq "ARRAY") {
3671       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3672         $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3673       }
3674     }
3675   }
3676
3677   my $saved_numberformat    = $::myconfig{numberformat};
3678   $::myconfig{numberformat} = $numberformat;
3679
3680   foreach my $idx (@indices) {
3681     if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3682       for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3683         $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3684       }
3685     }
3686
3687     next unless defined $self->{$idx};
3688
3689     if (!ref($self->{$idx})) {
3690       $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3691
3692     } elsif (ref($self->{$idx}) eq "ARRAY") {
3693       for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3694         $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3695       }
3696     }
3697   }
3698
3699   $::myconfig{numberformat} = $saved_numberformat;
3700 }
3701
3702 1;
3703
3704 __END__
3705
3706 =head1 NAME
3707
3708 SL::Form.pm - main data object.
3709
3710 =head1 SYNOPSIS
3711
3712 This is the main data object of Lx-Office.
3713 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3714 Points of interest for a beginner are:
3715
3716  - $form->error            - renders a generic error in html. accepts an error message
3717  - $form->get_standard_dbh - returns a database connection for the
3718
3719 =head1 SPECIAL FUNCTIONS
3720
3721 =head2 C<_store_value()>
3722
3723 parses a complex var name, and stores it in the form.
3724
3725 syntax:
3726   $form->_store_value($key, $value);
3727
3728 keys must start with a string, and can contain various tokens.
3729 supported key structures are:
3730
3731 1. simple access
3732   simple key strings work as expected
3733
3734   id => $form->{id}
3735
3736 2. hash access.
3737   separating two keys by a dot (.) will result in a hash lookup for the inner value
3738   this is similar to the behaviour of java and templating mechanisms.
3739
3740   filter.description => $form->{filter}->{description}
3741
3742 3. array+hashref access
3743
3744   adding brackets ([]) before the dot will cause the next hash to be put into an array.
3745   using [+] instead of [] will force a new array index. this is useful for recurring
3746   data structures like part lists. put a [+] into the first varname, and use [] on the
3747   following ones.
3748
3749   repeating these names in your template:
3750
3751     invoice.items[+].id
3752     invoice.items[].parts_id
3753
3754   will result in:
3755
3756     $form->{invoice}->{items}->[
3757       {
3758         id       => ...
3759         parts_id => ...
3760       },
3761       {
3762         id       => ...
3763         parts_id => ...
3764       }
3765       ...
3766     ]
3767
3768 4. arrays
3769
3770   using brackets at the end of a name will result in a pure array to be created.
3771   note that you mustn't use [+], which is reserved for array+hash access and will
3772   result in undefined behaviour in array context.
3773
3774   filter.status[]  => $form->{status}->[ val1, val2, ... ]
3775
3776 =head2 C<update_business> PARAMS
3777
3778 PARAMS (not named):
3779  \%config,     - config hashref
3780  $business_id, - business id
3781  $dbh          - optional database handle
3782
3783 handles business (thats customer/vendor types) sequences.
3784
3785 special behaviour for empty strings in customerinitnumber field:
3786 will in this case not increase the value, and return undef.
3787
3788 =head2 C<redirect_header> $url
3789
3790 Generates a HTTP redirection header for the new C<$url>. Constructs an
3791 absolute URL including scheme, host name and port. If C<$url> is a
3792 relative URL then it is considered relative to Lx-Office base URL.
3793
3794 This function C<die>s if headers have already been created with
3795 C<$::form-E<gt>header>.
3796
3797 Examples:
3798
3799   print $::form->redirect_header('oe.pl?action=edit&id=1234');
3800   print $::form->redirect_header('http://www.lx-office.org/');
3801
3802 =head2 C<header>
3803
3804 Generates a general purpose http/html header and includes most of the scripts
3805 ans stylesheets needed.
3806
3807 Only one header will be generated. If the method was already called in this
3808 request it will not output anything and return undef. Also if no
3809 HTTP_USER_AGENT is found, no header is generated.
3810
3811 Although header does not accept parameters itself, it will honor special
3812 hashkeys of its Form instance:
3813
3814 =over 4
3815
3816 =item refresh_time
3817
3818 =item refresh_url
3819
3820 If one of these is set, a http-equiv refresh is generated. Missing parameters
3821 default to 3 seconds and the refering url.
3822
3823 =item stylesheet
3824
3825 =item stylesheets
3826
3827 If these are arrayrefs the contents will be inlined into the header.
3828
3829 =item landscape
3830
3831 If true, a css snippet will be generated that sets the page in landscape mode.
3832
3833 =item favicon
3834
3835 Used to override the default favicon.
3836
3837 =item title
3838
3839 A html page title will be generated from this
3840
3841 =back
3842
3843 =cut