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