1 #====================================================================
4 # Based on SQL-Ledger Version 2.1.9
5 # Web http://www.lx-office.org
7 #=====================================================================
8 # SQL-Ledger Accounting
9 # Copyright (C) 1998-2002
11 # Author: Dieter Simader
12 # Email: dsimader@sql-ledger.org
13 # Web: http://www.sql-ledger.org
15 # Contributors: Thomas Bayen <bayen@gmx.de>
16 # Antti Kaihola <akaihola@siba.fi>
17 # Moritz Bunkus (tex code)
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.
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
36 #======================================================================
59 use List::Util qw(first max min sum);
60 use List::MoreUtils qw(any apply);
67 disconnect_standard_dbh();
70 sub disconnect_standard_dbh {
71 return unless $standard_dbh;
72 $standard_dbh->disconnect();
77 $main::lxdebug->enter_sub(2);
83 my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
88 $curr = \ $self->{ shift @tokens };
92 my $sep = shift @tokens;
93 my $key = shift @tokens;
95 $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]';
96 $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
97 $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
98 $curr = \ $$curr->{$key}
103 $main::lxdebug->leave_sub(2);
109 $main::lxdebug->enter_sub(2);
114 my @pairs = split(/&/, $input);
117 my ($key, $value) = split(/=/, $_, 2);
118 $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key);
121 $main::lxdebug->leave_sub(2);
124 sub _request_to_hash {
125 $main::lxdebug->enter_sub(2);
130 if (!$ENV{'CONTENT_TYPE'}
131 || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
133 $self->_input_to_hash($input);
135 $main::lxdebug->leave_sub(2);
139 my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
141 my $boundary = '--' . $1;
143 foreach my $line (split m/\n/, $input) {
144 last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
146 if (($line eq $boundary) || ($line eq "$boundary\r")) {
147 ${ $previous } =~ s|\r?\n$|| if $previous;
153 $content_type = "text/plain";
160 next unless $boundary_found;
162 if (!$headers_done) {
163 $line =~ s/[\r\n]*$//;
170 if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
171 if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
173 substr $line, $-[0], $+[0] - $-[0], "";
176 if ($line =~ m|name\s*=\s*"(.*?)"|i) {
178 substr $line, $-[0], $+[0] - $-[0], "";
181 $previous = $self->_store_value($name, '') if ($name);
182 $self->{FILENAME} = $filename if ($filename);
187 if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
194 next unless $previous;
196 ${ $previous } .= "${line}\n";
199 ${ $previous } =~ s|\r?\n$|| if $previous;
201 $main::lxdebug->leave_sub(2);
204 sub _recode_recursively {
205 $main::lxdebug->enter_sub();
206 my ($iconv, $param) = @_;
208 if (any { ref $param eq $_ } qw(Form HASH)) {
209 foreach my $key (keys %{ $param }) {
210 if (!ref $param->{$key}) {
211 # Workaround for a bug: converting $param->{$key} directly
212 # leads to 'undef'. I don't know why. Converting a copy works,
214 $param->{$key} = $iconv->convert("" . $param->{$key});
216 _recode_recursively($iconv, $param->{$key});
220 } elsif (ref $param eq 'ARRAY') {
221 foreach my $idx (0 .. scalar(@{ $param }) - 1) {
222 if (!ref $param->[$idx]) {
223 # Workaround for a bug: converting $param->[$idx] directly
224 # leads to 'undef'. I don't know why. Converting a copy works,
226 $param->[$idx] = $iconv->convert("" . $param->[$idx]);
228 _recode_recursively($iconv, $param->[$idx]);
232 $main::lxdebug->leave_sub();
236 $main::lxdebug->enter_sub();
242 if ($LXDebug::watch_form) {
243 require SL::Watchdog;
244 tie %{ $self }, 'SL::Watchdog';
249 $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
250 $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0];
252 if ($ENV{CONTENT_LENGTH}) {
254 read STDIN, $content, $ENV{CONTENT_LENGTH};
255 $self->_request_to_hash($content);
258 my $db_charset = $main::dbcharset;
259 $db_charset ||= Common::DEFAULT_CHARSET;
261 my $encoding = $self->{INPUT_ENCODING} || $db_charset;
262 delete $self->{INPUT_ENCODING};
264 _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self);
266 $self->{action} = lc $self->{action};
267 $self->{action} =~ s/( |-|,|\#)/_/g;
269 #$self->{version} = "2.6.1"; # Old hardcoded but secure style
270 open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file
271 $self->{version} = <VERSION_FILE>;
273 $self->{version} =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code.
275 $main::lxdebug->leave_sub();
280 sub _flatten_variables_rec {
281 $main::lxdebug->enter_sub(2);
290 if ('' eq ref $curr->{$key}) {
291 @result = ({ 'key' => $prefix . $key, 'value' => $curr->{$key} });
293 } elsif ('HASH' eq ref $curr->{$key}) {
294 foreach my $hash_key (sort keys %{ $curr->{$key} }) {
295 push @result, $self->_flatten_variables_rec($curr->{$key}, $prefix . $key . '.', $hash_key);
299 foreach my $idx (0 .. scalar @{ $curr->{$key} } - 1) {
300 my $first_array_entry = 1;
302 foreach my $hash_key (sort keys %{ $curr->{$key}->[$idx] }) {
303 push @result, $self->_flatten_variables_rec($curr->{$key}->[$idx], $prefix . $key . ($first_array_entry ? '[+].' : '[].'), $hash_key);
304 $first_array_entry = 0;
309 $main::lxdebug->leave_sub(2);
314 sub flatten_variables {
315 $main::lxdebug->enter_sub(2);
323 push @variables, $self->_flatten_variables_rec($self, '', $_);
326 $main::lxdebug->leave_sub(2);
331 sub flatten_standard_variables {
332 $main::lxdebug->enter_sub(2);
335 my %skip_keys = map { $_ => 1 } (qw(login password header stylesheet titlebar version), @_);
339 foreach (grep { ! $skip_keys{$_} } keys %{ $self }) {
340 push @variables, $self->_flatten_variables_rec($self, '', $_);
343 $main::lxdebug->leave_sub(2);
349 $main::lxdebug->enter_sub();
355 map { print "$_ = $self->{$_}\n" } (sort keys %{$self});
357 $main::lxdebug->leave_sub();
361 $main::lxdebug->enter_sub(2);
364 my $password = $self->{password};
366 $self->{password} = 'X' x 8;
368 local $Data::Dumper::Sortkeys = 1;
369 my $output = Dumper($self);
371 $self->{password} = $password;
373 $main::lxdebug->leave_sub(2);
379 $main::lxdebug->enter_sub(2);
381 my ($self, $str) = @_;
383 $str = Encode::encode('utf-8-strict', $str) if $::locale->is_utf8;
384 $str =~ s/([^a-zA-Z0-9_.-])/sprintf("%%%02x", ord($1))/ge;
386 $main::lxdebug->leave_sub(2);
392 $main::lxdebug->enter_sub(2);
394 my ($self, $str) = @_;
399 $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
401 $main::lxdebug->leave_sub(2);
407 $main::lxdebug->enter_sub();
408 my ($self, $str) = @_;
410 if ($str && !ref($str)) {
411 $str =~ s/\"/"/g;
414 $main::lxdebug->leave_sub();
420 $main::lxdebug->enter_sub();
421 my ($self, $str) = @_;
423 if ($str && !ref($str)) {
424 $str =~ s/"/\"/g;
427 $main::lxdebug->leave_sub();
433 $main::lxdebug->enter_sub();
437 map({ print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_);
439 for (sort keys %$self) {
440 next if (($_ eq "header") || (ref($self->{$_}) ne ""));
441 print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n");
444 $main::lxdebug->leave_sub();
448 $main::lxdebug->enter_sub();
450 $main::lxdebug->show_backtrace();
452 my ($self, $msg) = @_;
453 if ($ENV{HTTP_USER_AGENT}) {
455 $self->show_generic_error($msg);
458 print STDERR "Error: $msg\n";
462 $main::lxdebug->leave_sub();
466 $main::lxdebug->enter_sub();
468 my ($self, $msg) = @_;
470 if ($ENV{HTTP_USER_AGENT}) {
473 if (!$self->{header}) {
479 <p class="message_ok"><b>$msg</b></p>
481 <script type="text/javascript">
483 // If JavaScript is enabled, the whole thing will be reloaded.
484 // The reason is: When one changes his menu setup (HTML / XUL / CSS ...)
485 // it now loads the correct code into the browser instead of do nothing.
486 setTimeout("top.frames.location.href='login.pl'",500);
495 if ($self->{info_function}) {
496 &{ $self->{info_function} }($msg);
502 $main::lxdebug->leave_sub();
505 # calculates the number of rows in a textarea based on the content and column number
506 # can be capped with maxrows
508 $main::lxdebug->enter_sub();
509 my ($self, $str, $cols, $maxrows, $minrows) = @_;
513 my $rows = sum map { int((length() - 2) / $cols) + 1 } split /\r/, $str;
516 $main::lxdebug->leave_sub();
518 return max(min($rows, $maxrows), $minrows);
522 $main::lxdebug->enter_sub();
524 my ($self, $msg) = @_;
526 $self->error("$msg\n" . $DBI::errstr);
528 $main::lxdebug->leave_sub();
532 $main::lxdebug->enter_sub();
534 my ($self, $name, $msg) = @_;
537 foreach my $part (split m/\./, $name) {
538 if (!$curr->{$part} || ($curr->{$part} =~ /^\s*$/)) {
541 $curr = $curr->{$part};
544 $main::lxdebug->leave_sub();
547 sub _get_request_uri {
550 return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
552 my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http';
553 my $port = $ENV{SERVER_PORT} || '';
554 $port = undef if (($scheme eq 'http' ) && ($port == 80))
555 || (($scheme eq 'https') && ($port == 443));
557 my $uri = URI->new("${scheme}://");
558 $uri->scheme($scheme);
560 $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
561 $uri->path_query($ENV{REQUEST_URI});
567 sub _add_to_request_uri {
570 my $relative_new_path = shift;
571 my $request_uri = shift || $self->_get_request_uri;
572 my $relative_new_uri = URI->new($relative_new_path);
573 my @request_segments = $request_uri->path_segments;
575 my $new_uri = $request_uri->clone;
576 $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments);
581 sub create_http_response {
582 $main::lxdebug->enter_sub();
587 my $cgi = $main::cgi;
588 $cgi ||= CGI->new('');
591 if (defined $main::auth) {
592 my $uri = $self->_get_request_uri;
593 my @segments = $uri->path_segments;
595 $uri->path_segments(@segments);
597 my $session_cookie_value = $main::auth->get_session_id();
598 $session_cookie_value ||= 'NO_SESSION';
600 $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
601 '-value' => $session_cookie_value,
602 '-path' => $uri->path,
603 '-secure' => $ENV{HTTPS});
606 my %cgi_params = ('-type' => $params{content_type});
607 $cgi_params{'-charset'} = $params{charset} if ($params{charset});
609 my $output = $cgi->header('-cookie' => $session_cookie,
612 $main::lxdebug->leave_sub();
619 $::lxdebug->enter_sub;
621 # extra code is currently only used by menuv3 and menuv4 to set their css.
622 # it is strongly deprecated, and will be changed in a future version.
623 my ($self, $extra_code) = @_;
624 my $db_charset = $::dbcharset || Common::DEFAULT_CHARSET;
627 $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
629 $self->{favicon} ||= "favicon.ico";
630 $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title};
633 if ($self->{refresh_url} || $self->{refresh_time}) {
634 my $refresh_time = $self->{refresh_time} || 3;
635 my $refresh_url = $self->{refresh_url} || $ENV{REFERER};
636 push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
639 push @header, "<link rel='stylesheet' href='css/$_' type='text/css' title='Lx-Office stylesheet'>"
640 for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets};
642 push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
643 push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
644 push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
645 '<script type="text/javascript" src="js/common.js"></script>',
646 '<style type="text/css">@import url(js/jscalendar/calendar-win2k-1.css);</style>',
647 '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
648 '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
649 '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
650 '<script type="text/javascript" src="js/part_selection.js"></script>';
651 push @header, $self->{javascript} if $self->{javascript};
652 push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
653 push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
654 push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
655 join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title};
657 # if there is a title, we put some JavaScript in to the page, wich writes a
658 # meaningful title-tag for our frameset.
660 if ($self->{title}) {
662 <script type="text/javascript">
664 // Write a meaningful title-tag for our frameset.
665 top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
671 print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
672 print "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01//EN' 'http://www.w3.org/TR/html4/strict.dtd'>\n"
673 if $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/; # Other browsers may choke on menu scripts with DOCTYPE.
677 <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
678 <title>$self->{titlebar}</title>
680 print " $_\n" for @header;
682 <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css" />
683 <meta name="robots" content="noindex,nofollow" />
684 <script type="text/javascript" src="js/highlight_input.js"></script>
685 <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
686 <script type="text/javascript" src="js/tabcontent.js">
688 /***********************************************
689 * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
690 * This notice MUST stay intact for legal use
691 * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
692 ***********************************************/
701 $::lxdebug->leave_sub;
704 sub ajax_response_header {
705 $main::lxdebug->enter_sub();
709 my $db_charset = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
710 my $cgi = $main::cgi || CGI->new('');
711 my $output = $cgi->header('-charset' => $db_charset);
713 $main::lxdebug->leave_sub();
718 sub redirect_header {
722 my $base_uri = $self->_get_request_uri;
723 my $new_uri = URI->new_abs($new_url, $base_uri);
725 die "Headers already sent" if $::self->{header};
728 my $cgi = $main::cgi || CGI->new('');
729 return $cgi->redirect($new_uri);
732 sub set_standard_title {
733 $::lxdebug->enter_sub;
736 $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
737 $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
738 $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
740 $::lxdebug->leave_sub;
743 sub _prepare_html_template {
744 $main::lxdebug->enter_sub();
746 my ($self, $file, $additional_params) = @_;
749 if (!%::myconfig || !$::myconfig{"countrycode"}) {
750 $language = $main::language;
752 $language = $main::myconfig{"countrycode"};
754 $language = "de" unless ($language);
756 if (-f "templates/webpages/${file}.html") {
757 if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
758 my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
759 "Please re-run 'locales.pl' in 'locale/${language}'.";
760 print(qq|<pre>$info</pre>|);
764 $file = "templates/webpages/${file}.html";
767 my $info = "Web page template '${file}' not found.\n" .
768 "Please re-run 'locales.pl' in 'locale/${language}'.";
769 print(qq|<pre>$info</pre>|);
773 if ($self->{"DEBUG"}) {
774 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
777 if ($additional_params->{"DEBUG"}) {
778 $additional_params->{"DEBUG"} =
779 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
782 if (%main::myconfig) {
783 $::myconfig{jsc_dateformat} = apply {
787 } $::myconfig{"dateformat"};
788 $additional_params->{"myconfig"} ||= \%::myconfig;
789 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
792 $additional_params->{"conf_dbcharset"} = $main::dbcharset;
793 $additional_params->{"conf_webdav"} = $main::webdav;
794 $additional_params->{"conf_lizenzen"} = $main::lizenzen;
795 $additional_params->{"conf_latex_templates"} = $main::latex;
796 $additional_params->{"conf_opendocument_templates"} = $main::opendocument_templates;
797 $additional_params->{"conf_vertreter"} = $main::vertreter;
798 $additional_params->{"conf_show_best_before"} = $main::show_best_before;
800 if (%main::debug_options) {
801 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
804 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
805 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
806 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
810 $main::lxdebug->leave_sub();
815 sub parse_html_template {
816 $main::lxdebug->enter_sub();
818 my ($self, $file, $additional_params) = @_;
820 $additional_params ||= { };
822 my $real_file = $self->_prepare_html_template($file, $additional_params);
823 my $template = $self->template || $self->init_template;
825 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
828 $template->process($real_file, $additional_params, \$output) || die $template->error;
830 $main::lxdebug->leave_sub();
838 return if $self->template;
840 return $self->template(Template->new({
845 'PLUGIN_BASE' => 'SL::Template::Plugin',
846 'INCLUDE_PATH' => '.:templates/webpages',
847 'COMPILE_EXT' => '.tcc',
848 'COMPILE_DIR' => $::userspath . '/templates-cache',
854 $self->{template_object} = shift if @_;
855 return $self->{template_object};
858 sub show_generic_error {
859 $main::lxdebug->enter_sub();
861 my ($self, $error, %params) = @_;
864 'title_error' => $params{title},
865 'label_error' => $error,
868 if ($params{action}) {
871 map { delete($self->{$_}); } qw(action);
872 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
874 $add_params->{SHOW_BUTTON} = 1;
875 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
876 $add_params->{VARIABLES} = \@vars;
878 } elsif ($params{back_button}) {
879 $add_params->{SHOW_BACK_BUTTON} = 1;
882 $self->{title} = $params{title} if $params{title};
885 print $self->parse_html_template("generic/error", $add_params);
887 print STDERR "Error: $error\n";
889 $main::lxdebug->leave_sub();
894 sub show_generic_information {
895 $main::lxdebug->enter_sub();
897 my ($self, $text, $title) = @_;
900 'title_information' => $title,
901 'label_information' => $text,
904 $self->{title} = $title if ($title);
907 print $self->parse_html_template("generic/information", $add_params);
909 $main::lxdebug->leave_sub();
914 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
915 # changed it to accept an arbitrary number of triggers - sschoeling
917 $main::lxdebug->enter_sub();
920 my $myconfig = shift;
923 # set dateform for jsscript
926 "dd.mm.yy" => "%d.%m.%Y",
927 "dd-mm-yy" => "%d-%m-%Y",
928 "dd/mm/yy" => "%d/%m/%Y",
929 "mm/dd/yy" => "%m/%d/%Y",
930 "mm-dd-yy" => "%m-%d-%Y",
931 "yyyy-mm-dd" => "%Y-%m-%d",
934 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
935 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
942 inputField : "| . (shift) . qq|",
943 ifFormat :"$ifFormat",
944 align : "| . (shift) . qq|",
945 button : "| . (shift) . qq|"
951 <script type="text/javascript">
952 <!--| . join("", @triggers) . qq|//-->
956 $main::lxdebug->leave_sub();
959 } #end sub write_trigger
962 $main::lxdebug->enter_sub();
964 my ($self, $msg) = @_;
966 if (!$self->{callback}) {
972 # my ($script, $argv) = split(/\?/, $self->{callback}, 2);
973 # $script =~ s|.*/||;
974 # $script =~ s|[^a-zA-Z0-9_\.]||g;
975 # exec("perl", "$script", $argv);
977 print $::form->redirect_header($self->{callback});
979 $main::lxdebug->leave_sub();
982 # sort of columns removed - empty sub
984 $main::lxdebug->enter_sub();
986 my ($self, @columns) = @_;
988 $main::lxdebug->leave_sub();
994 $main::lxdebug->enter_sub(2);
996 my ($self, $myconfig, $amount, $places, $dash) = @_;
1002 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1004 my $neg = ($amount =~ s/^-//);
1005 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1007 if (defined($places) && ($places ne '')) {
1013 my ($actual_places) = ($amount =~ /\.(\d+)/);
1014 $actual_places = length($actual_places);
1015 $places = $actual_places > $places ? $actual_places : $places;
1018 $amount = $self->round_amount($amount, $places);
1021 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1022 my @p = split(/\./, $amount); # split amount at decimal point
1024 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1027 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1030 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1031 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1032 ($neg ? "-$amount" : "$amount" ) ;
1036 $main::lxdebug->leave_sub(2);
1040 sub format_amount_units {
1041 $main::lxdebug->enter_sub();
1046 my $myconfig = \%main::myconfig;
1047 my $amount = $params{amount} * 1;
1048 my $places = $params{places};
1049 my $part_unit_name = $params{part_unit};
1050 my $amount_unit_name = $params{amount_unit};
1051 my $conv_units = $params{conv_units};
1052 my $max_places = $params{max_places};
1054 if (!$part_unit_name) {
1055 $main::lxdebug->leave_sub();
1059 AM->retrieve_all_units();
1060 my $all_units = $main::all_units;
1062 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1063 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1066 if (!scalar @{ $conv_units }) {
1067 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1068 $main::lxdebug->leave_sub();
1072 my $part_unit = $all_units->{$part_unit_name};
1073 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1075 $amount *= $conv_unit->{factor};
1080 foreach my $unit (@$conv_units) {
1081 my $last = $unit->{name} eq $part_unit->{name};
1083 $num = int($amount / $unit->{factor});
1084 $amount -= $num * $unit->{factor};
1087 if ($last ? $amount : $num) {
1088 push @values, { "unit" => $unit->{name},
1089 "amount" => $last ? $amount / $unit->{factor} : $num,
1090 "places" => $last ? $places : 0 };
1097 push @values, { "unit" => $part_unit_name,
1102 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1104 $main::lxdebug->leave_sub();
1110 $main::lxdebug->enter_sub(2);
1115 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1116 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1117 $input =~ s/\#\#/\#/g;
1119 $main::lxdebug->leave_sub(2);
1127 $main::lxdebug->enter_sub(2);
1129 my ($self, $myconfig, $amount) = @_;
1131 if ( ($myconfig->{numberformat} eq '1.000,00')
1132 || ($myconfig->{numberformat} eq '1000,00')) {
1137 if ($myconfig->{numberformat} eq "1'000.00") {
1143 $main::lxdebug->leave_sub(2);
1145 return ($amount * 1);
1149 $main::lxdebug->enter_sub(2);
1151 my ($self, $amount, $places) = @_;
1154 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1156 # Round amounts to eight places before rounding to the requested
1157 # number of places. This gets rid of errors due to internal floating
1158 # point representation.
1159 $amount = $self->round_amount($amount, 8) if $places < 8;
1160 $amount = $amount * (10**($places));
1161 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1163 $main::lxdebug->leave_sub(2);
1165 return $round_amount;
1169 sub parse_template {
1170 $main::lxdebug->enter_sub();
1172 my ($self, $myconfig, $userspath) = @_;
1177 $self->{"cwd"} = getcwd();
1178 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1183 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1184 $template_type = 'OpenDocument';
1185 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1187 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1188 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1189 $template_type = 'LaTeX';
1190 $ext_for_format = 'pdf';
1192 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1193 $template_type = 'HTML';
1194 $ext_for_format = 'html';
1196 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1197 $template_type = 'XML';
1198 $ext_for_format = 'xml';
1200 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1201 $template_type = 'xml';
1203 } elsif ( $self->{"format"} =~ /excel/i ) {
1204 $template_type = 'Excel';
1205 $ext_for_format = 'xls';
1207 } elsif ( defined $self->{'format'}) {
1208 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1210 } elsif ( $self->{'format'} eq '' ) {
1211 $self->error("No Outputformat given: $self->{'format'}");
1213 } else { #Catch the rest
1214 $self->error("Outputformat not defined: $self->{'format'}");
1217 my $template = SL::Template::create(type => $template_type,
1218 file_name => $self->{IN},
1220 myconfig => $myconfig,
1221 userspath => $userspath);
1223 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1224 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1226 if (!$self->{employee_id}) {
1227 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1230 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1232 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1234 # OUT is used for the media, screen, printer, email
1235 # for postscript we store a copy in a temporary file
1237 my $prepend_userspath;
1239 if (!$self->{tmpfile}) {
1240 $self->{tmpfile} = "${fileid}.$self->{IN}";
1241 $prepend_userspath = 1;
1244 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1246 $self->{tmpfile} =~ s|.*/||;
1247 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1248 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1250 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1251 $out = $self->{OUT};
1252 $self->{OUT} = ">$self->{tmpfile}";
1258 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1259 $result = $template->parse(*OUT);
1264 $result = $template->parse(*STDOUT);
1269 $self->error("$self->{IN} : " . $template->get_error());
1272 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1274 if ($self->{media} eq 'email') {
1276 my $mail = new Mailer;
1278 map { $mail->{$_} = $self->{$_} }
1279 qw(cc bcc subject message version format);
1280 $mail->{charset} = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
1281 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1282 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1283 $mail->{fileid} = "$fileid.";
1284 $myconfig->{signature} =~ s/\r//g;
1286 # if we send html or plain text inline
1287 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1288 $mail->{contenttype} = "text/html";
1290 $mail->{message} =~ s/\r//g;
1291 $mail->{message} =~ s/\n/<br>\n/g;
1292 $myconfig->{signature} =~ s/\n/<br>\n/g;
1293 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1295 open(IN, $self->{tmpfile})
1296 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1298 $mail->{message} .= $_;
1305 if (!$self->{"do_not_attach"}) {
1306 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1307 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1308 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1309 "name" => $attachment_name }];
1312 $mail->{message} =~ s/\r//g;
1313 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1317 my $err = $mail->send();
1318 $self->error($self->cleanup . "$err") if ($err);
1322 $self->{OUT} = $out;
1324 my $numbytes = (-s $self->{tmpfile});
1325 open(IN, $self->{tmpfile})
1326 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1328 $self->{copies} = 1 unless $self->{media} eq 'printer';
1330 chdir("$self->{cwd}");
1331 #print(STDERR "Kopien $self->{copies}\n");
1332 #print(STDERR "OUT $self->{OUT}\n");
1333 for my $i (1 .. $self->{copies}) {
1335 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1336 print OUT while <IN>;
1341 $self->{attachment_filename} = ($self->{attachment_filename})
1342 ? $self->{attachment_filename}
1343 : $self->generate_attachment_filename();
1345 # launch application
1346 print qq|Content-Type: | . $template->get_mime_type() . qq|
1347 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1348 Content-Length: $numbytes
1352 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1363 chdir("$self->{cwd}");
1364 $main::lxdebug->leave_sub();
1367 sub get_formname_translation {
1368 $main::lxdebug->enter_sub();
1369 my ($self, $formname) = @_;
1371 $formname ||= $self->{formname};
1373 my %formname_translations = (
1374 bin_list => $main::locale->text('Bin List'),
1375 credit_note => $main::locale->text('Credit Note'),
1376 invoice => $main::locale->text('Invoice'),
1377 packing_list => $main::locale->text('Packing List'),
1378 pick_list => $main::locale->text('Pick List'),
1379 proforma => $main::locale->text('Proforma Invoice'),
1380 purchase_order => $main::locale->text('Purchase Order'),
1381 request_quotation => $main::locale->text('RFQ'),
1382 sales_order => $main::locale->text('Confirmation'),
1383 sales_quotation => $main::locale->text('Quotation'),
1384 storno_invoice => $main::locale->text('Storno Invoice'),
1385 storno_packing_list => $main::locale->text('Storno Packing List'),
1386 sales_delivery_order => $main::locale->text('Delivery Order'),
1387 purchase_delivery_order => $main::locale->text('Delivery Order'),
1388 dunning => $main::locale->text('Dunning'),
1391 $main::lxdebug->leave_sub();
1392 return $formname_translations{$formname}
1395 sub get_number_prefix_for_type {
1396 $main::lxdebug->enter_sub();
1400 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1401 : ($self->{type} =~ /_quotation$/) ? 'quo'
1402 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1405 $main::lxdebug->leave_sub();
1409 sub get_extension_for_format {
1410 $main::lxdebug->enter_sub();
1413 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1414 : $self->{format} =~ /postscript/i ? ".ps"
1415 : $self->{format} =~ /opendocument/i ? ".odt"
1416 : $self->{format} =~ /excel/i ? ".xls"
1417 : $self->{format} =~ /html/i ? ".html"
1420 $main::lxdebug->leave_sub();
1424 sub generate_attachment_filename {
1425 $main::lxdebug->enter_sub();
1428 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1429 my $prefix = $self->get_number_prefix_for_type();
1431 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1432 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1434 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1435 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1438 $attachment_filename = "";
1441 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1442 $attachment_filename =~ s|[\s/\\]+|_|g;
1444 $main::lxdebug->leave_sub();
1445 return $attachment_filename;
1448 sub generate_email_subject {
1449 $main::lxdebug->enter_sub();
1452 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1453 my $prefix = $self->get_number_prefix_for_type();
1455 if ($subject && $self->{"${prefix}number"}) {
1456 $subject .= " " . $self->{"${prefix}number"}
1459 $main::lxdebug->leave_sub();
1464 $main::lxdebug->enter_sub();
1468 chdir("$self->{tmpdir}");
1471 if (-f "$self->{tmpfile}.err") {
1472 open(FH, "$self->{tmpfile}.err");
1477 if ($self->{tmpfile} && ! $::keep_temp_files) {
1478 $self->{tmpfile} =~ s|.*/||g;
1480 $self->{tmpfile} =~ s/\.\w+$//g;
1481 my $tmpfile = $self->{tmpfile};
1482 unlink(<$tmpfile.*>);
1485 chdir("$self->{cwd}");
1487 $main::lxdebug->leave_sub();
1493 $main::lxdebug->enter_sub();
1495 my ($self, $date, $myconfig) = @_;
1498 if ($date && $date =~ /\D/) {
1500 if ($myconfig->{dateformat} =~ /^yy/) {
1501 ($yy, $mm, $dd) = split /\D/, $date;
1503 if ($myconfig->{dateformat} =~ /^mm/) {
1504 ($mm, $dd, $yy) = split /\D/, $date;
1506 if ($myconfig->{dateformat} =~ /^dd/) {
1507 ($dd, $mm, $yy) = split /\D/, $date;
1512 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1513 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1515 $dd = "0$dd" if ($dd < 10);
1516 $mm = "0$mm" if ($mm < 10);
1518 $date = "$yy$mm$dd";
1521 $main::lxdebug->leave_sub();
1526 # Database routines used throughout
1528 sub _dbconnect_options {
1530 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1537 $main::lxdebug->enter_sub(2);
1539 my ($self, $myconfig) = @_;
1541 # connect to database
1542 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1546 if ($myconfig->{dboptions}) {
1547 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1550 $main::lxdebug->leave_sub(2);
1555 sub dbconnect_noauto {
1556 $main::lxdebug->enter_sub();
1558 my ($self, $myconfig) = @_;
1560 # connect to database
1561 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1565 if ($myconfig->{dboptions}) {
1566 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1569 $main::lxdebug->leave_sub();
1574 sub get_standard_dbh {
1575 $main::lxdebug->enter_sub(2);
1578 my $myconfig = shift || \%::myconfig;
1580 if ($standard_dbh && !$standard_dbh->{Active}) {
1581 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1582 undef $standard_dbh;
1585 $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1587 $main::lxdebug->leave_sub(2);
1589 return $standard_dbh;
1593 $main::lxdebug->enter_sub();
1595 my ($self, $date, $myconfig) = @_;
1596 my $dbh = $self->dbconnect($myconfig);
1598 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1599 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1600 my ($closed) = $sth->fetchrow_array;
1602 $main::lxdebug->leave_sub();
1607 sub update_balance {
1608 $main::lxdebug->enter_sub();
1610 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1612 # if we have a value, go do it
1615 # retrieve balance from table
1616 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1617 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1618 my ($balance) = $sth->fetchrow_array;
1624 $query = "UPDATE $table SET $field = $balance WHERE $where";
1625 do_query($self, $dbh, $query, @values);
1627 $main::lxdebug->leave_sub();
1630 sub update_exchangerate {
1631 $main::lxdebug->enter_sub();
1633 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1635 # some sanity check for currency
1637 $main::lxdebug->leave_sub();
1640 $query = qq|SELECT curr FROM defaults|;
1642 my ($currency) = selectrow_query($self, $dbh, $query);
1643 my ($defaultcurrency) = split m/:/, $currency;
1646 if ($curr eq $defaultcurrency) {
1647 $main::lxdebug->leave_sub();
1651 $query = qq|SELECT e.curr FROM exchangerate e
1652 WHERE e.curr = ? AND e.transdate = ?
1654 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1663 $buy = conv_i($buy, "NULL");
1664 $sell = conv_i($sell, "NULL");
1667 if ($buy != 0 && $sell != 0) {
1668 $set = "buy = $buy, sell = $sell";
1669 } elsif ($buy != 0) {
1670 $set = "buy = $buy";
1671 } elsif ($sell != 0) {
1672 $set = "sell = $sell";
1675 if ($sth->fetchrow_array) {
1676 $query = qq|UPDATE exchangerate
1682 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1683 VALUES (?, $buy, $sell, ?)|;
1686 do_query($self, $dbh, $query, $curr, $transdate);
1688 $main::lxdebug->leave_sub();
1691 sub save_exchangerate {
1692 $main::lxdebug->enter_sub();
1694 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1696 my $dbh = $self->dbconnect($myconfig);
1700 $buy = $rate if $fld eq 'buy';
1701 $sell = $rate if $fld eq 'sell';
1704 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1709 $main::lxdebug->leave_sub();
1712 sub get_exchangerate {
1713 $main::lxdebug->enter_sub();
1715 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1718 unless ($transdate) {
1719 $main::lxdebug->leave_sub();
1723 $query = qq|SELECT curr FROM defaults|;
1725 my ($currency) = selectrow_query($self, $dbh, $query);
1726 my ($defaultcurrency) = split m/:/, $currency;
1728 if ($currency eq $defaultcurrency) {
1729 $main::lxdebug->leave_sub();
1733 $query = qq|SELECT e.$fld FROM exchangerate e
1734 WHERE e.curr = ? AND e.transdate = ?|;
1735 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1739 $main::lxdebug->leave_sub();
1741 return $exchangerate;
1744 sub check_exchangerate {
1745 $main::lxdebug->enter_sub();
1747 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1749 if ($fld !~/^buy|sell$/) {
1750 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1753 unless ($transdate) {
1754 $main::lxdebug->leave_sub();
1758 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1760 if ($currency eq $defaultcurrency) {
1761 $main::lxdebug->leave_sub();
1765 my $dbh = $self->get_standard_dbh($myconfig);
1766 my $query = qq|SELECT e.$fld FROM exchangerate e
1767 WHERE e.curr = ? AND e.transdate = ?|;
1769 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1771 $main::lxdebug->leave_sub();
1773 return $exchangerate;
1776 sub get_all_currencies {
1777 $main::lxdebug->enter_sub();
1780 my $myconfig = shift || \%::myconfig;
1781 my $dbh = $self->get_standard_dbh($myconfig);
1783 my $query = qq|SELECT curr FROM defaults|;
1785 my ($curr) = selectrow_query($self, $dbh, $query);
1786 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1788 $main::lxdebug->leave_sub();
1793 sub get_default_currency {
1794 $main::lxdebug->enter_sub();
1796 my ($self, $myconfig) = @_;
1797 my @currencies = $self->get_all_currencies($myconfig);
1799 $main::lxdebug->leave_sub();
1801 return $currencies[0];
1804 sub set_payment_options {
1805 $main::lxdebug->enter_sub();
1807 my ($self, $myconfig, $transdate) = @_;
1809 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1811 my $dbh = $self->get_standard_dbh($myconfig);
1814 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1815 qq|FROM payment_terms p | .
1818 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1819 $self->{payment_terms}) =
1820 selectrow_query($self, $dbh, $query, $self->{payment_id});
1822 if ($transdate eq "") {
1823 if ($self->{invdate}) {
1824 $transdate = $self->{invdate};
1826 $transdate = $self->{transdate};
1831 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1832 qq|FROM payment_terms|;
1833 ($self->{netto_date}, $self->{skonto_date}) =
1834 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1836 my ($invtotal, $total);
1837 my (%amounts, %formatted_amounts);
1839 if ($self->{type} =~ /_order$/) {
1840 $amounts{invtotal} = $self->{ordtotal};
1841 $amounts{total} = $self->{ordtotal};
1843 } elsif ($self->{type} =~ /_quotation$/) {
1844 $amounts{invtotal} = $self->{quototal};
1845 $amounts{total} = $self->{quototal};
1848 $amounts{invtotal} = $self->{invtotal};
1849 $amounts{total} = $self->{total};
1851 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1853 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1855 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1856 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1857 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1859 foreach (keys %amounts) {
1860 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1861 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1864 if ($self->{"language_id"}) {
1866 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1867 qq|FROM translation_payment_terms t | .
1868 qq|LEFT JOIN language l ON t.language_id = l.id | .
1869 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1870 my ($description_long, $output_numberformat, $output_dateformat,
1871 $output_longdates) =
1872 selectrow_query($self, $dbh, $query,
1873 $self->{"language_id"}, $self->{"payment_id"});
1875 $self->{payment_terms} = $description_long if ($description_long);
1877 if ($output_dateformat) {
1878 foreach my $key (qw(netto_date skonto_date)) {
1880 $main::locale->reformat_date($myconfig, $self->{$key},
1886 if ($output_numberformat &&
1887 ($output_numberformat ne $myconfig->{"numberformat"})) {
1888 my $saved_numberformat = $myconfig->{"numberformat"};
1889 $myconfig->{"numberformat"} = $output_numberformat;
1890 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1891 $myconfig->{"numberformat"} = $saved_numberformat;
1895 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1896 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1897 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1898 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1899 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1900 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1901 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1903 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1905 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1907 $main::lxdebug->leave_sub();
1911 sub get_template_language {
1912 $main::lxdebug->enter_sub();
1914 my ($self, $myconfig) = @_;
1916 my $template_code = "";
1918 if ($self->{language_id}) {
1919 my $dbh = $self->get_standard_dbh($myconfig);
1920 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1921 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1924 $main::lxdebug->leave_sub();
1926 return $template_code;
1929 sub get_printer_code {
1930 $main::lxdebug->enter_sub();
1932 my ($self, $myconfig) = @_;
1934 my $template_code = "";
1936 if ($self->{printer_id}) {
1937 my $dbh = $self->get_standard_dbh($myconfig);
1938 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1939 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1942 $main::lxdebug->leave_sub();
1944 return $template_code;
1948 $main::lxdebug->enter_sub();
1950 my ($self, $myconfig) = @_;
1952 my $template_code = "";
1954 if ($self->{shipto_id}) {
1955 my $dbh = $self->get_standard_dbh($myconfig);
1956 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1957 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1958 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1961 $main::lxdebug->leave_sub();
1965 $main::lxdebug->enter_sub();
1967 my ($self, $dbh, $id, $module) = @_;
1972 foreach my $item (qw(name department_1 department_2 street zipcode city country
1973 contact cp_gender phone fax email)) {
1974 if ($self->{"shipto$item"}) {
1975 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1977 push(@values, $self->{"shipto${item}"});
1981 if ($self->{shipto_id}) {
1982 my $query = qq|UPDATE shipto set
1984 shiptodepartment_1 = ?,
1985 shiptodepartment_2 = ?,
1991 shiptocp_gender = ?,
1995 WHERE shipto_id = ?|;
1996 do_query($self, $dbh, $query, @values, $self->{shipto_id});
1998 my $query = qq|SELECT * FROM shipto
1999 WHERE shiptoname = ? AND
2000 shiptodepartment_1 = ? AND
2001 shiptodepartment_2 = ? AND
2002 shiptostreet = ? AND
2003 shiptozipcode = ? AND
2005 shiptocountry = ? AND
2006 shiptocontact = ? AND
2007 shiptocp_gender = ? AND
2013 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2016 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2017 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2018 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2019 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2020 do_query($self, $dbh, $query, $id, @values, $module);
2025 $main::lxdebug->leave_sub();
2029 $main::lxdebug->enter_sub();
2031 my ($self, $dbh) = @_;
2033 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2035 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2036 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2037 $self->{"employee_id"} *= 1;
2039 $main::lxdebug->leave_sub();
2042 sub get_employee_data {
2043 $main::lxdebug->enter_sub();
2048 Common::check_params(\%params, qw(prefix));
2049 Common::check_params_x(\%params, qw(id));
2052 $main::lxdebug->leave_sub();
2056 my $myconfig = \%main::myconfig;
2057 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2059 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2062 my $user = User->new($login);
2063 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2065 $self->{$params{prefix} . '_login'} = $login;
2066 $self->{$params{prefix} . '_name'} ||= $login;
2069 $main::lxdebug->leave_sub();
2073 $main::lxdebug->enter_sub();
2075 my ($self, $myconfig, $reference_date) = @_;
2077 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2079 my $dbh = $self->get_standard_dbh($myconfig);
2080 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2081 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2083 $main::lxdebug->leave_sub();
2089 $main::lxdebug->enter_sub();
2091 my ($self, $dbh, $id, $key) = @_;
2093 $key = "all_contacts" unless ($key);
2097 $main::lxdebug->leave_sub();
2102 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2103 qq|FROM contacts | .
2104 qq|WHERE cp_cv_id = ? | .
2105 qq|ORDER BY lower(cp_name)|;
2107 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2109 $main::lxdebug->leave_sub();
2113 $main::lxdebug->enter_sub();
2115 my ($self, $dbh, $key) = @_;
2117 my ($all, $old_id, $where, @values);
2119 if (ref($key) eq "HASH") {
2122 $key = "ALL_PROJECTS";
2124 foreach my $p (keys(%{$params})) {
2126 $all = $params->{$p};
2127 } elsif ($p eq "old_id") {
2128 $old_id = $params->{$p};
2129 } elsif ($p eq "key") {
2130 $key = $params->{$p};
2136 $where = "WHERE active ";
2138 if (ref($old_id) eq "ARRAY") {
2139 my @ids = grep({ $_ } @{$old_id});
2141 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2142 push(@values, @ids);
2145 $where .= " OR (id = ?) ";
2146 push(@values, $old_id);
2152 qq|SELECT id, projectnumber, description, active | .
2155 qq|ORDER BY lower(projectnumber)|;
2157 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2159 $main::lxdebug->leave_sub();
2163 $main::lxdebug->enter_sub();
2165 my ($self, $dbh, $vc_id, $key) = @_;
2167 $key = "all_shipto" unless ($key);
2170 # get shipping addresses
2171 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2173 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2179 $main::lxdebug->leave_sub();
2183 $main::lxdebug->enter_sub();
2185 my ($self, $dbh, $key) = @_;
2187 $key = "all_printers" unless ($key);
2189 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2191 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2193 $main::lxdebug->leave_sub();
2197 $main::lxdebug->enter_sub();
2199 my ($self, $dbh, $params) = @_;
2202 $key = $params->{key};
2203 $key = "all_charts" unless ($key);
2205 my $transdate = quote_db_date($params->{transdate});
2208 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2210 qq|LEFT JOIN taxkeys tk ON | .
2211 qq|(tk.id = (SELECT id FROM taxkeys | .
2212 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2213 qq| ORDER BY startdate DESC LIMIT 1)) | .
2214 qq|ORDER BY c.accno|;
2216 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2218 $main::lxdebug->leave_sub();
2221 sub _get_taxcharts {
2222 $main::lxdebug->enter_sub();
2224 my ($self, $dbh, $params) = @_;
2226 my $key = "all_taxcharts";
2229 if (ref $params eq 'HASH') {
2230 $key = $params->{key} if ($params->{key});
2231 if ($params->{module} eq 'AR') {
2232 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2234 } elsif ($params->{module} eq 'AP') {
2235 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2242 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2244 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2246 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2248 $main::lxdebug->leave_sub();
2252 $main::lxdebug->enter_sub();
2254 my ($self, $dbh, $key) = @_;
2256 $key = "all_taxzones" unless ($key);
2258 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2260 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2262 $main::lxdebug->leave_sub();
2265 sub _get_employees {
2266 $main::lxdebug->enter_sub();
2268 my ($self, $dbh, $default_key, $key) = @_;
2270 $key = $default_key unless ($key);
2271 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2273 $main::lxdebug->leave_sub();
2276 sub _get_business_types {
2277 $main::lxdebug->enter_sub();
2279 my ($self, $dbh, $key) = @_;
2281 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2282 $options->{key} ||= "all_business_types";
2285 if (exists $options->{salesman}) {
2286 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2289 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2291 $main::lxdebug->leave_sub();
2294 sub _get_languages {
2295 $main::lxdebug->enter_sub();
2297 my ($self, $dbh, $key) = @_;
2299 $key = "all_languages" unless ($key);
2301 my $query = qq|SELECT * FROM language ORDER BY id|;
2303 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2305 $main::lxdebug->leave_sub();
2308 sub _get_dunning_configs {
2309 $main::lxdebug->enter_sub();
2311 my ($self, $dbh, $key) = @_;
2313 $key = "all_dunning_configs" unless ($key);
2315 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2317 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2319 $main::lxdebug->leave_sub();
2322 sub _get_currencies {
2323 $main::lxdebug->enter_sub();
2325 my ($self, $dbh, $key) = @_;
2327 $key = "all_currencies" unless ($key);
2329 my $query = qq|SELECT curr AS currency FROM defaults|;
2331 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2333 $main::lxdebug->leave_sub();
2337 $main::lxdebug->enter_sub();
2339 my ($self, $dbh, $key) = @_;
2341 $key = "all_payments" unless ($key);
2343 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2345 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2347 $main::lxdebug->leave_sub();
2350 sub _get_customers {
2351 $main::lxdebug->enter_sub();
2353 my ($self, $dbh, $key) = @_;
2355 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2356 $options->{key} ||= "all_customers";
2357 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2360 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2361 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2362 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2364 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2365 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2367 $main::lxdebug->leave_sub();
2371 $main::lxdebug->enter_sub();
2373 my ($self, $dbh, $key) = @_;
2375 $key = "all_vendors" unless ($key);
2377 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2379 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2381 $main::lxdebug->leave_sub();
2384 sub _get_departments {
2385 $main::lxdebug->enter_sub();
2387 my ($self, $dbh, $key) = @_;
2389 $key = "all_departments" unless ($key);
2391 my $query = qq|SELECT * FROM department ORDER BY description|;
2393 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2395 $main::lxdebug->leave_sub();
2398 sub _get_warehouses {
2399 $main::lxdebug->enter_sub();
2401 my ($self, $dbh, $param) = @_;
2403 my ($key, $bins_key);
2405 if ('' eq ref $param) {
2409 $key = $param->{key};
2410 $bins_key = $param->{bins};
2413 my $query = qq|SELECT w.* FROM warehouse w
2414 WHERE (NOT w.invalid) AND
2415 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2416 ORDER BY w.sortkey|;
2418 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2421 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2422 my $sth = prepare_query($self, $dbh, $query);
2424 foreach my $warehouse (@{ $self->{$key} }) {
2425 do_statement($self, $sth, $query, $warehouse->{id});
2426 $warehouse->{$bins_key} = [];
2428 while (my $ref = $sth->fetchrow_hashref()) {
2429 push @{ $warehouse->{$bins_key} }, $ref;
2435 $main::lxdebug->leave_sub();
2439 $main::lxdebug->enter_sub();
2441 my ($self, $dbh, $table, $key, $sortkey) = @_;
2443 my $query = qq|SELECT * FROM $table|;
2444 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2446 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2448 $main::lxdebug->leave_sub();
2452 # $main::lxdebug->enter_sub();
2454 # my ($self, $dbh, $key) = @_;
2456 # $key ||= "all_groups";
2458 # my $groups = $main::auth->read_groups();
2460 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2462 # $main::lxdebug->leave_sub();
2466 $main::lxdebug->enter_sub();
2471 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2472 my ($sth, $query, $ref);
2474 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2475 my $vc_id = $self->{"${vc}_id"};
2477 if ($params{"contacts"}) {
2478 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2481 if ($params{"shipto"}) {
2482 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2485 if ($params{"projects"} || $params{"all_projects"}) {
2486 $self->_get_projects($dbh, $params{"all_projects"} ?
2487 $params{"all_projects"} : $params{"projects"},
2488 $params{"all_projects"} ? 1 : 0);
2491 if ($params{"printers"}) {
2492 $self->_get_printers($dbh, $params{"printers"});
2495 if ($params{"languages"}) {
2496 $self->_get_languages($dbh, $params{"languages"});
2499 if ($params{"charts"}) {
2500 $self->_get_charts($dbh, $params{"charts"});
2503 if ($params{"taxcharts"}) {
2504 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2507 if ($params{"taxzones"}) {
2508 $self->_get_taxzones($dbh, $params{"taxzones"});
2511 if ($params{"employees"}) {
2512 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2515 if ($params{"salesmen"}) {
2516 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2519 if ($params{"business_types"}) {
2520 $self->_get_business_types($dbh, $params{"business_types"});
2523 if ($params{"dunning_configs"}) {
2524 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2527 if($params{"currencies"}) {
2528 $self->_get_currencies($dbh, $params{"currencies"});
2531 if($params{"customers"}) {
2532 $self->_get_customers($dbh, $params{"customers"});
2535 if($params{"vendors"}) {
2536 if (ref $params{"vendors"} eq 'HASH') {
2537 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2539 $self->_get_vendors($dbh, $params{"vendors"});
2543 if($params{"payments"}) {
2544 $self->_get_payments($dbh, $params{"payments"});
2547 if($params{"departments"}) {
2548 $self->_get_departments($dbh, $params{"departments"});
2551 if ($params{price_factors}) {
2552 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2555 if ($params{warehouses}) {
2556 $self->_get_warehouses($dbh, $params{warehouses});
2559 # if ($params{groups}) {
2560 # $self->_get_groups($dbh, $params{groups});
2563 if ($params{partsgroup}) {
2564 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2567 $main::lxdebug->leave_sub();
2570 # this sub gets the id and name from $table
2572 $main::lxdebug->enter_sub();
2574 my ($self, $myconfig, $table) = @_;
2576 # connect to database
2577 my $dbh = $self->get_standard_dbh($myconfig);
2579 $table = $table eq "customer" ? "customer" : "vendor";
2580 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2582 my ($query, @values);
2584 if (!$self->{openinvoices}) {
2586 if ($self->{customernumber} ne "") {
2587 $where = qq|(vc.customernumber ILIKE ?)|;
2588 push(@values, '%' . $self->{customernumber} . '%');
2590 $where = qq|(vc.name ILIKE ?)|;
2591 push(@values, '%' . $self->{$table} . '%');
2595 qq~SELECT vc.id, vc.name,
2596 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2598 WHERE $where AND (NOT vc.obsolete)
2602 qq~SELECT DISTINCT vc.id, vc.name,
2603 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2605 JOIN $table vc ON (a.${table}_id = vc.id)
2606 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2608 push(@values, '%' . $self->{$table} . '%');
2611 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2613 $main::lxdebug->leave_sub();
2615 return scalar(@{ $self->{name_list} });
2618 # the selection sub is used in the AR, AP, IS, IR and OE module
2621 $main::lxdebug->enter_sub();
2623 my ($self, $myconfig, $table, $module) = @_;
2626 my $dbh = $self->get_standard_dbh;
2628 $table = $table eq "customer" ? "customer" : "vendor";
2630 my $query = qq|SELECT count(*) FROM $table|;
2631 my ($count) = selectrow_query($self, $dbh, $query);
2633 # build selection list
2634 if ($count <= $myconfig->{vclimit}) {
2635 $query = qq|SELECT id, name, salesman_id
2636 FROM $table WHERE NOT obsolete
2638 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2642 $self->get_employee($dbh);
2644 # setup sales contacts
2645 $query = qq|SELECT e.id, e.name
2647 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2648 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2651 push(@{ $self->{all_employees} },
2652 { id => $self->{employee_id},
2653 name => $self->{employee} });
2655 # sort the whole thing
2656 @{ $self->{all_employees} } =
2657 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2659 if ($module eq 'AR') {
2661 # prepare query for departments
2662 $query = qq|SELECT id, description
2665 ORDER BY description|;
2668 $query = qq|SELECT id, description
2670 ORDER BY description|;
2673 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2676 $query = qq|SELECT id, description
2680 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2683 $query = qq|SELECT printer_description, id
2685 ORDER BY printer_description|;
2687 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2690 $query = qq|SELECT id, description
2694 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2696 $main::lxdebug->leave_sub();
2699 sub language_payment {
2700 $main::lxdebug->enter_sub();
2702 my ($self, $myconfig) = @_;
2704 my $dbh = $self->get_standard_dbh($myconfig);
2706 my $query = qq|SELECT id, description
2710 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2713 $query = qq|SELECT printer_description, id
2715 ORDER BY printer_description|;
2717 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2720 $query = qq|SELECT id, description
2724 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2726 # get buchungsgruppen
2727 $query = qq|SELECT id, description
2728 FROM buchungsgruppen|;
2730 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2732 $main::lxdebug->leave_sub();
2735 # this is only used for reports
2736 sub all_departments {
2737 $main::lxdebug->enter_sub();
2739 my ($self, $myconfig, $table) = @_;
2741 my $dbh = $self->get_standard_dbh($myconfig);
2744 if ($table eq 'customer') {
2745 $where = "WHERE role = 'P' ";
2748 my $query = qq|SELECT id, description
2751 ORDER BY description|;
2752 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2754 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2756 $main::lxdebug->leave_sub();
2760 $main::lxdebug->enter_sub();
2762 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2765 if ($table eq "customer") {
2774 $self->all_vc($myconfig, $table, $module);
2776 # get last customers or vendors
2777 my ($query, $sth, $ref);
2779 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2784 my $transdate = "current_date";
2785 if ($self->{transdate}) {
2786 $transdate = $dbh->quote($self->{transdate});
2789 # now get the account numbers
2790 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2791 FROM chart c, taxkeys tk
2792 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2793 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2796 $sth = $dbh->prepare($query);
2798 do_statement($self, $sth, $query, '%' . $module . '%');
2800 $self->{accounts} = "";
2801 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2803 foreach my $key (split(/:/, $ref->{link})) {
2804 if ($key =~ /\Q$module\E/) {
2806 # cross reference for keys
2807 $xkeyref{ $ref->{accno} } = $key;
2809 push @{ $self->{"${module}_links"}{$key} },
2810 { accno => $ref->{accno},
2811 description => $ref->{description},
2812 taxkey => $ref->{taxkey_id},
2813 tax_id => $ref->{tax_id} };
2815 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2821 # get taxkeys and description
2822 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2823 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2825 if (($module eq "AP") || ($module eq "AR")) {
2826 # get tax rates and description
2827 $query = qq|SELECT * FROM tax|;
2828 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2834 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2835 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2836 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2837 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2839 d.description AS department,
2842 JOIN $table c ON (a.${table}_id = c.id)
2843 LEFT JOIN employee e ON (e.id = a.employee_id)
2844 LEFT JOIN department d ON (d.id = a.department_id)
2846 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2848 foreach my $key (keys %$ref) {
2849 $self->{$key} = $ref->{$key};
2852 my $transdate = "current_date";
2853 if ($self->{transdate}) {
2854 $transdate = $dbh->quote($self->{transdate});
2857 # now get the account numbers
2858 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2860 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2862 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2863 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2866 $sth = $dbh->prepare($query);
2867 do_statement($self, $sth, $query, "%$module%");
2869 $self->{accounts} = "";
2870 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2872 foreach my $key (split(/:/, $ref->{link})) {
2873 if ($key =~ /\Q$module\E/) {
2875 # cross reference for keys
2876 $xkeyref{ $ref->{accno} } = $key;
2878 push @{ $self->{"${module}_links"}{$key} },
2879 { accno => $ref->{accno},
2880 description => $ref->{description},
2881 taxkey => $ref->{taxkey_id},
2882 tax_id => $ref->{tax_id} };
2884 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2890 # get amounts from individual entries
2893 c.accno, c.description,
2894 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2898 LEFT JOIN chart c ON (c.id = a.chart_id)
2899 LEFT JOIN project p ON (p.id = a.project_id)
2900 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2901 WHERE (tk.taxkey_id=a.taxkey) AND
2902 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2903 THEN tk.chart_id = a.chart_id
2906 OR (c.link='%tax%')) AND
2907 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2908 WHERE a.trans_id = ?
2909 AND a.fx_transaction = '0'
2910 ORDER BY a.acc_trans_id, a.transdate|;
2911 $sth = $dbh->prepare($query);
2912 do_statement($self, $sth, $query, $self->{id});
2914 # get exchangerate for currency
2915 $self->{exchangerate} =
2916 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2919 # store amounts in {acc_trans}{$key} for multiple accounts
2920 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2921 $ref->{exchangerate} =
2922 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2923 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2926 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2927 $ref->{amount} *= -1;
2929 $ref->{index} = $index;
2931 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2937 d.curr AS currencies, d.closedto, d.revtrans,
2938 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2939 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2941 $ref = selectfirst_hashref_query($self, $dbh, $query);
2942 map { $self->{$_} = $ref->{$_} } keys %$ref;
2949 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2950 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2951 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2953 $ref = selectfirst_hashref_query($self, $dbh, $query);
2954 map { $self->{$_} = $ref->{$_} } keys %$ref;
2956 if ($self->{"$self->{vc}_id"}) {
2958 # only setup currency
2959 ($self->{currency}) = split(/:/, $self->{currencies});
2963 $self->lastname_used($dbh, $myconfig, $table, $module);
2965 # get exchangerate for currency
2966 $self->{exchangerate} =
2967 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2973 $main::lxdebug->leave_sub();
2977 $main::lxdebug->enter_sub();
2979 my ($self, $dbh, $myconfig, $table, $module) = @_;
2983 $table = $table eq "customer" ? "customer" : "vendor";
2984 my %column_map = ("a.curr" => "currency",
2985 "a.${table}_id" => "${table}_id",
2986 "a.department_id" => "department_id",
2987 "d.description" => "department",
2988 "ct.name" => $table,
2989 "current_date + ct.terms" => "duedate",
2992 if ($self->{type} =~ /delivery_order/) {
2993 $arap = 'delivery_orders';
2994 delete $column_map{"a.curr"};
2996 } elsif ($self->{type} =~ /_order/) {
2998 $where = "quotation = '0'";
3000 } elsif ($self->{type} =~ /_quotation/) {
3002 $where = "quotation = '1'";
3004 } elsif ($table eq 'customer') {
3012 $where = "($where) AND" if ($where);
3013 my $query = qq|SELECT MAX(id) FROM $arap
3014 WHERE $where ${table}_id > 0|;
3015 my ($trans_id) = selectrow_query($self, $dbh, $query);
3018 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3019 $query = qq|SELECT $column_spec
3021 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3022 LEFT JOIN department d ON (a.department_id = d.id)
3024 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3026 map { $self->{$_} = $ref->{$_} } values %column_map;
3028 $main::lxdebug->leave_sub();
3032 $main::lxdebug->enter_sub();
3035 my $myconfig = shift || \%::myconfig;
3036 my ($thisdate, $days) = @_;
3038 my $dbh = $self->get_standard_dbh($myconfig);
3043 my $dateformat = $myconfig->{dateformat};
3044 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3045 $thisdate = $dbh->quote($thisdate);
3046 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3048 $query = qq|SELECT current_date AS thisdate|;
3051 ($thisdate) = selectrow_query($self, $dbh, $query);
3053 $main::lxdebug->leave_sub();
3059 $main::lxdebug->enter_sub();
3061 my ($self, $string) = @_;
3063 if ($string !~ /%/) {
3064 $string = "%$string%";
3067 $string =~ s/\'/\'\'/g;
3069 $main::lxdebug->leave_sub();
3075 $main::lxdebug->enter_sub();
3077 my ($self, $flds, $new, $count, $numrows) = @_;
3081 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3086 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3088 my $j = $item->{ndx} - 1;
3089 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3093 for $i ($count + 1 .. $numrows) {
3094 map { delete $self->{"${_}_$i"} } @{$flds};
3097 $main::lxdebug->leave_sub();
3101 $main::lxdebug->enter_sub();
3103 my ($self, $myconfig) = @_;
3107 my $dbh = $self->dbconnect_noauto($myconfig);
3109 my $query = qq|DELETE FROM status
3110 WHERE (formname = ?) AND (trans_id = ?)|;
3111 my $sth = prepare_query($self, $dbh, $query);
3113 if ($self->{formname} =~ /(check|receipt)/) {
3114 for $i (1 .. $self->{rowcount}) {
3115 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3118 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3122 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3123 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3125 my %queued = split / /, $self->{queued};
3128 if ($self->{formname} =~ /(check|receipt)/) {
3130 # this is a check or receipt, add one entry for each lineitem
3131 my ($accno) = split /--/, $self->{account};
3132 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3133 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3134 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3135 $sth = prepare_query($self, $dbh, $query);
3137 for $i (1 .. $self->{rowcount}) {
3138 if ($self->{"checked_$i"}) {
3139 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3145 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3146 VALUES (?, ?, ?, ?, ?)|;
3147 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3148 $queued{$self->{formname}}, $self->{formname});
3154 $main::lxdebug->leave_sub();
3158 $main::lxdebug->enter_sub();
3160 my ($self, $dbh) = @_;
3162 my ($query, $printed, $emailed);
3164 my $formnames = $self->{printed};
3165 my $emailforms = $self->{emailed};
3167 $query = qq|DELETE FROM status
3168 WHERE (formname = ?) AND (trans_id = ?)|;
3169 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3171 # this only applies to the forms
3172 # checks and receipts are posted when printed or queued
3174 if ($self->{queued}) {
3175 my %queued = split / /, $self->{queued};
3177 foreach my $formname (keys %queued) {
3178 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3179 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3181 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3182 VALUES (?, ?, ?, ?, ?)|;
3183 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3185 $formnames =~ s/\Q$self->{formname}\E//;
3186 $emailforms =~ s/\Q$self->{formname}\E//;
3191 # save printed, emailed info
3192 $formnames =~ s/^ +//g;
3193 $emailforms =~ s/^ +//g;
3196 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3197 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3199 foreach my $formname (keys %status) {
3200 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3201 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3203 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3204 VALUES (?, ?, ?, ?)|;
3205 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3208 $main::lxdebug->leave_sub();
3212 # $main::locale->text('SAVED')
3213 # $main::locale->text('DELETED')
3214 # $main::locale->text('ADDED')
3215 # $main::locale->text('PAYMENT POSTED')
3216 # $main::locale->text('POSTED')
3217 # $main::locale->text('POSTED AS NEW')
3218 # $main::locale->text('ELSE')
3219 # $main::locale->text('SAVED FOR DUNNING')
3220 # $main::locale->text('DUNNING STARTED')
3221 # $main::locale->text('PRINTED')
3222 # $main::locale->text('MAILED')
3223 # $main::locale->text('SCREENED')
3224 # $main::locale->text('CANCELED')
3225 # $main::locale->text('invoice')
3226 # $main::locale->text('proforma')
3227 # $main::locale->text('sales_order')
3228 # $main::locale->text('packing_list')
3229 # $main::locale->text('pick_list')
3230 # $main::locale->text('purchase_order')
3231 # $main::locale->text('bin_list')
3232 # $main::locale->text('sales_quotation')
3233 # $main::locale->text('request_quotation')
3236 $main::lxdebug->enter_sub();
3239 my $dbh = shift || $self->get_standard_dbh;
3241 if(!exists $self->{employee_id}) {
3242 &get_employee($self, $dbh);
3246 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3247 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3248 my @values = (conv_i($self->{id}), $self->{login},
3249 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3250 do_query($self, $dbh, $query, @values);
3254 $main::lxdebug->leave_sub();
3258 $main::lxdebug->enter_sub();
3260 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3261 my ($orderBy, $desc) = split(/\-\-/, $order);
3262 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3265 if ($trans_id ne "") {
3267 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 | .
3268 qq|FROM history_erp h | .
3269 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3270 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3273 my $sth = $dbh->prepare($query) || $self->dberror($query);
3275 $sth->execute() || $self->dberror("$query");
3277 while(my $hash_ref = $sth->fetchrow_hashref()) {
3278 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3279 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3280 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3281 $tempArray[$i++] = $hash_ref;
3283 $main::lxdebug->leave_sub() and return \@tempArray
3284 if ($i > 0 && $tempArray[0] ne "");
3286 $main::lxdebug->leave_sub();
3290 sub update_defaults {
3291 $main::lxdebug->enter_sub();
3293 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3296 if ($provided_dbh) {
3297 $dbh = $provided_dbh;
3299 $dbh = $self->dbconnect_noauto($myconfig);
3301 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3302 my $sth = $dbh->prepare($query);
3304 $sth->execute || $self->dberror($query);
3305 my ($var) = $sth->fetchrow_array;
3308 if ($var =~ m/\d+$/) {
3309 my $new_var = (substr $var, $-[0]) * 1 + 1;
3310 my $len_diff = length($var) - $-[0] - length($new_var);
3311 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3317 $query = qq|UPDATE defaults SET $fld = ?|;
3318 do_query($self, $dbh, $query, $var);
3320 if (!$provided_dbh) {
3325 $main::lxdebug->leave_sub();
3330 sub update_business {
3331 $main::lxdebug->enter_sub();
3333 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3336 if ($provided_dbh) {
3337 $dbh = $provided_dbh;
3339 $dbh = $self->dbconnect_noauto($myconfig);
3342 qq|SELECT customernumberinit FROM business
3343 WHERE id = ? FOR UPDATE|;
3344 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3346 return undef unless $var;
3348 if ($var =~ m/\d+$/) {
3349 my $new_var = (substr $var, $-[0]) * 1 + 1;
3350 my $len_diff = length($var) - $-[0] - length($new_var);
3351 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3357 $query = qq|UPDATE business
3358 SET customernumberinit = ?
3360 do_query($self, $dbh, $query, $var, $business_id);
3362 if (!$provided_dbh) {
3367 $main::lxdebug->leave_sub();
3372 sub get_partsgroup {
3373 $main::lxdebug->enter_sub();
3375 my ($self, $myconfig, $p) = @_;
3376 my $target = $p->{target} || 'all_partsgroup';
3378 my $dbh = $self->get_standard_dbh($myconfig);
3380 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3382 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3385 if ($p->{searchitems} eq 'part') {
3386 $query .= qq|WHERE p.inventory_accno_id > 0|;
3388 if ($p->{searchitems} eq 'service') {
3389 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3391 if ($p->{searchitems} eq 'assembly') {
3392 $query .= qq|WHERE p.assembly = '1'|;
3394 if ($p->{searchitems} eq 'labor') {
3395 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3398 $query .= qq|ORDER BY partsgroup|;
3401 $query = qq|SELECT id, partsgroup FROM partsgroup
3402 ORDER BY partsgroup|;
3405 if ($p->{language_code}) {
3406 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3407 t.description AS translation
3409 JOIN parts p ON (p.partsgroup_id = pg.id)
3410 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3411 ORDER BY translation|;
3412 @values = ($p->{language_code});
3415 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3417 $main::lxdebug->leave_sub();
3420 sub get_pricegroup {
3421 $main::lxdebug->enter_sub();
3423 my ($self, $myconfig, $p) = @_;
3425 my $dbh = $self->get_standard_dbh($myconfig);
3427 my $query = qq|SELECT p.id, p.pricegroup
3430 $query .= qq| ORDER BY pricegroup|;
3433 $query = qq|SELECT id, pricegroup FROM pricegroup
3434 ORDER BY pricegroup|;
3437 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3439 $main::lxdebug->leave_sub();
3443 # usage $form->all_years($myconfig, [$dbh])
3444 # return list of all years where bookings found
3447 $main::lxdebug->enter_sub();
3449 my ($self, $myconfig, $dbh) = @_;
3451 $dbh ||= $self->get_standard_dbh($myconfig);
3454 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3455 (SELECT MAX(transdate) FROM acc_trans)|;
3456 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3458 if ($myconfig->{dateformat} =~ /^yy/) {
3459 ($startdate) = split /\W/, $startdate;
3460 ($enddate) = split /\W/, $enddate;
3462 (@_) = split /\W/, $startdate;
3464 (@_) = split /\W/, $enddate;
3469 $startdate = substr($startdate,0,4);
3470 $enddate = substr($enddate,0,4);
3472 while ($enddate >= $startdate) {
3473 push @all_years, $enddate--;
3478 $main::lxdebug->leave_sub();
3482 $main::lxdebug->enter_sub();
3486 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3488 $main::lxdebug->leave_sub();
3492 $main::lxdebug->enter_sub();
3497 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3499 $main::lxdebug->leave_sub();
3508 SL::Form.pm - main data object.
3512 This is the main data object of Lx-Office.
3513 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3514 Points of interest for a beginner are:
3516 - $form->error - renders a generic error in html. accepts an error message
3517 - $form->get_standard_dbh - returns a database connection for the
3519 =head1 SPECIAL FUNCTIONS
3521 =head2 C<_store_value()>
3523 parses a complex var name, and stores it in the form.
3526 $form->_store_value($key, $value);
3528 keys must start with a string, and can contain various tokens.
3529 supported key structures are:
3532 simple key strings work as expected
3537 separating two keys by a dot (.) will result in a hash lookup for the inner value
3538 this is similar to the behaviour of java and templating mechanisms.
3540 filter.description => $form->{filter}->{description}
3542 3. array+hashref access
3544 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3545 using [+] instead of [] will force a new array index. this is useful for recurring
3546 data structures like part lists. put a [+] into the first varname, and use [] on the
3549 repeating these names in your template:
3552 invoice.items[].parts_id
3556 $form->{invoice}->{items}->[
3570 using brackets at the end of a name will result in a pure array to be created.
3571 note that you mustn't use [+], which is reserved for array+hash access and will
3572 result in undefined behaviour in array context.
3574 filter.status[] => $form->{status}->[ val1, val2, ... ]
3576 =head2 C<update_business> PARAMS
3579 \%config, - config hashref
3580 $business_id, - business id
3581 $dbh - optional database handle
3583 handles business (thats customer/vendor types) sequences.
3585 special behaviour for empty strings in customerinitnumber field:
3586 will in this case not increase the value, and return undef.
3588 =head2 C<redirect_header> $url
3590 Generates a HTTP redirection header for the new C<$url>. Constructs an
3591 absolute URL including scheme, host name and port. If C<$url> is a
3592 relative URL then it is considered relative to Lx-Office base URL.
3594 This function C<die>s if headers have already been created with
3595 C<$::form-E<gt>header>.
3599 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3600 print $::form->redirect_header('http://www.lx-office.org/');
3604 Generates a general purpose http/html header and includes most of the scripts
3605 ans stylesheets needed.
3607 Only one header will be generated. If the method was already called in this
3608 request it will not output anything and return undef. Also if no
3609 HTTP_USER_AGENT is found, no header is generated.
3611 Although header does not accept parameters itself, it will honor special
3612 hashkeys of its Form instance:
3620 If one of these is set, a http-equiv refresh is generated. Missing parameters
3621 default to 3 seconds and the refering url.
3627 If these are arrayrefs the contents will be inlined into the header.
3631 If true, a css snippet will be generated that sets the page in landscape mode.
3635 Used to override the default favicon.
3639 A html page title will be generated from this