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