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