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