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