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