SL/Form.pm

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