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