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