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"} = $::dbcharset;
793 $additional_params->{"conf_webdav"} = $::webdav;
794 $additional_params->{"conf_lizenzen"} = $::lizenzen;
795 $additional_params->{"conf_latex_templates"} = $::latex;
796 $additional_params->{"conf_opendocument_templates"} = $::opendocument_templates;
797 $additional_params->{"conf_vertreter"} = $::vertreter;
798 $additional_params->{"conf_show_best_before"} = $::show_best_before;
799 $additional_params->{"conf_parts_image_css"} = $::parts_image_css;
800 $additional_params->{"conf_parts_listing_images"} = $::parts_listing_images;
801 $additional_params->{"conf_parts_show_image"} = $::parts_show_image;
803 if (%main::debug_options) {
804 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
807 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
808 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
809 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
813 $main::lxdebug->leave_sub();
818 sub parse_html_template {
819 $main::lxdebug->enter_sub();
821 my ($self, $file, $additional_params) = @_;
823 $additional_params ||= { };
825 my $real_file = $self->_prepare_html_template($file, $additional_params);
826 my $template = $self->template || $self->init_template;
828 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
831 $template->process($real_file, $additional_params, \$output) || die $template->error;
833 $main::lxdebug->leave_sub();
841 return if $self->template;
843 return $self->template(Template->new({
848 'PLUGIN_BASE' => 'SL::Template::Plugin',
849 'INCLUDE_PATH' => '.:templates/webpages',
850 'COMPILE_EXT' => '.tcc',
851 'COMPILE_DIR' => $::userspath . '/templates-cache',
857 $self->{template_object} = shift if @_;
858 return $self->{template_object};
861 sub show_generic_error {
862 $main::lxdebug->enter_sub();
864 my ($self, $error, %params) = @_;
867 'title_error' => $params{title},
868 'label_error' => $error,
871 if ($params{action}) {
874 map { delete($self->{$_}); } qw(action);
875 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
877 $add_params->{SHOW_BUTTON} = 1;
878 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
879 $add_params->{VARIABLES} = \@vars;
881 } elsif ($params{back_button}) {
882 $add_params->{SHOW_BACK_BUTTON} = 1;
885 $self->{title} = $params{title} if $params{title};
888 print $self->parse_html_template("generic/error", $add_params);
890 print STDERR "Error: $error\n";
892 $main::lxdebug->leave_sub();
897 sub show_generic_information {
898 $main::lxdebug->enter_sub();
900 my ($self, $text, $title) = @_;
903 'title_information' => $title,
904 'label_information' => $text,
907 $self->{title} = $title if ($title);
910 print $self->parse_html_template("generic/information", $add_params);
912 $main::lxdebug->leave_sub();
917 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
918 # changed it to accept an arbitrary number of triggers - sschoeling
920 $main::lxdebug->enter_sub();
923 my $myconfig = shift;
926 # set dateform for jsscript
929 "dd.mm.yy" => "%d.%m.%Y",
930 "dd-mm-yy" => "%d-%m-%Y",
931 "dd/mm/yy" => "%d/%m/%Y",
932 "mm/dd/yy" => "%m/%d/%Y",
933 "mm-dd-yy" => "%m-%d-%Y",
934 "yyyy-mm-dd" => "%Y-%m-%d",
937 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
938 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
945 inputField : "| . (shift) . qq|",
946 ifFormat :"$ifFormat",
947 align : "| . (shift) . qq|",
948 button : "| . (shift) . qq|"
954 <script type="text/javascript">
955 <!--| . join("", @triggers) . qq|//-->
959 $main::lxdebug->leave_sub();
962 } #end sub write_trigger
965 $main::lxdebug->enter_sub();
967 my ($self, $msg) = @_;
969 if (!$self->{callback}) {
975 # my ($script, $argv) = split(/\?/, $self->{callback}, 2);
976 # $script =~ s|.*/||;
977 # $script =~ s|[^a-zA-Z0-9_\.]||g;
978 # exec("perl", "$script", $argv);
980 print $::form->redirect_header($self->{callback});
982 $main::lxdebug->leave_sub();
985 # sort of columns removed - empty sub
987 $main::lxdebug->enter_sub();
989 my ($self, @columns) = @_;
991 $main::lxdebug->leave_sub();
997 $main::lxdebug->enter_sub(2);
999 my ($self, $myconfig, $amount, $places, $dash) = @_;
1001 if ($amount eq "") {
1005 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1007 my $neg = ($amount =~ s/^-//);
1008 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1010 if (defined($places) && ($places ne '')) {
1016 my ($actual_places) = ($amount =~ /\.(\d+)/);
1017 $actual_places = length($actual_places);
1018 $places = $actual_places > $places ? $actual_places : $places;
1021 $amount = $self->round_amount($amount, $places);
1024 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1025 my @p = split(/\./, $amount); # split amount at decimal point
1027 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1030 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1033 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1034 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1035 ($neg ? "-$amount" : "$amount" ) ;
1039 $main::lxdebug->leave_sub(2);
1043 sub format_amount_units {
1044 $main::lxdebug->enter_sub();
1049 my $myconfig = \%main::myconfig;
1050 my $amount = $params{amount} * 1;
1051 my $places = $params{places};
1052 my $part_unit_name = $params{part_unit};
1053 my $amount_unit_name = $params{amount_unit};
1054 my $conv_units = $params{conv_units};
1055 my $max_places = $params{max_places};
1057 if (!$part_unit_name) {
1058 $main::lxdebug->leave_sub();
1062 AM->retrieve_all_units();
1063 my $all_units = $main::all_units;
1065 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1066 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1069 if (!scalar @{ $conv_units }) {
1070 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1071 $main::lxdebug->leave_sub();
1075 my $part_unit = $all_units->{$part_unit_name};
1076 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1078 $amount *= $conv_unit->{factor};
1083 foreach my $unit (@$conv_units) {
1084 my $last = $unit->{name} eq $part_unit->{name};
1086 $num = int($amount / $unit->{factor});
1087 $amount -= $num * $unit->{factor};
1090 if ($last ? $amount : $num) {
1091 push @values, { "unit" => $unit->{name},
1092 "amount" => $last ? $amount / $unit->{factor} : $num,
1093 "places" => $last ? $places : 0 };
1100 push @values, { "unit" => $part_unit_name,
1105 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1107 $main::lxdebug->leave_sub();
1113 $main::lxdebug->enter_sub(2);
1118 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1119 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1120 $input =~ s/\#\#/\#/g;
1122 $main::lxdebug->leave_sub(2);
1130 $main::lxdebug->enter_sub(2);
1132 my ($self, $myconfig, $amount) = @_;
1134 if ( ($myconfig->{numberformat} eq '1.000,00')
1135 || ($myconfig->{numberformat} eq '1000,00')) {
1140 if ($myconfig->{numberformat} eq "1'000.00") {
1146 $main::lxdebug->leave_sub(2);
1148 return ($amount * 1);
1152 $main::lxdebug->enter_sub(2);
1154 my ($self, $amount, $places) = @_;
1157 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1159 # Round amounts to eight places before rounding to the requested
1160 # number of places. This gets rid of errors due to internal floating
1161 # point representation.
1162 $amount = $self->round_amount($amount, 8) if $places < 8;
1163 $amount = $amount * (10**($places));
1164 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1166 $main::lxdebug->leave_sub(2);
1168 return $round_amount;
1172 sub parse_template {
1173 $main::lxdebug->enter_sub();
1175 my ($self, $myconfig, $userspath) = @_;
1180 $self->{"cwd"} = getcwd();
1181 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1186 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1187 $template_type = 'OpenDocument';
1188 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1190 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1191 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1192 $template_type = 'LaTeX';
1193 $ext_for_format = 'pdf';
1195 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1196 $template_type = 'HTML';
1197 $ext_for_format = 'html';
1199 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1200 $template_type = 'XML';
1201 $ext_for_format = 'xml';
1203 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1204 $template_type = 'XML';
1206 } elsif ( $self->{"format"} =~ /excel/i ) {
1207 $template_type = 'Excel';
1208 $ext_for_format = 'xls';
1210 } elsif ( defined $self->{'format'}) {
1211 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1213 } elsif ( $self->{'format'} eq '' ) {
1214 $self->error("No Outputformat given: $self->{'format'}");
1216 } else { #Catch the rest
1217 $self->error("Outputformat not defined: $self->{'format'}");
1220 my $template = SL::Template::create(type => $template_type,
1221 file_name => $self->{IN},
1223 myconfig => $myconfig,
1224 userspath => $userspath);
1226 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1227 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1229 if (!$self->{employee_id}) {
1230 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1233 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1235 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1237 # OUT is used for the media, screen, printer, email
1238 # for postscript we store a copy in a temporary file
1240 my $prepend_userspath;
1242 if (!$self->{tmpfile}) {
1243 $self->{tmpfile} = "${fileid}.$self->{IN}";
1244 $prepend_userspath = 1;
1247 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1249 $self->{tmpfile} =~ s|.*/||;
1250 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1251 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1253 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1254 $out = $self->{OUT};
1255 $self->{OUT} = ">$self->{tmpfile}";
1261 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1262 $result = $template->parse(*OUT);
1267 $result = $template->parse(*STDOUT);
1272 $self->error("$self->{IN} : " . $template->get_error());
1275 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1277 if ($self->{media} eq 'email') {
1279 my $mail = new Mailer;
1281 map { $mail->{$_} = $self->{$_} }
1282 qw(cc bcc subject message version format);
1283 $mail->{charset} = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
1284 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1285 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1286 $mail->{fileid} = "$fileid.";
1287 $myconfig->{signature} =~ s/\r//g;
1289 # if we send html or plain text inline
1290 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1291 $mail->{contenttype} = "text/html";
1293 $mail->{message} =~ s/\r//g;
1294 $mail->{message} =~ s/\n/<br>\n/g;
1295 $myconfig->{signature} =~ s/\n/<br>\n/g;
1296 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1298 open(IN, $self->{tmpfile})
1299 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1301 $mail->{message} .= $_;
1308 if (!$self->{"do_not_attach"}) {
1309 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1310 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1311 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1312 "name" => $attachment_name }];
1315 $mail->{message} =~ s/\r//g;
1316 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1320 my $err = $mail->send();
1321 $self->error($self->cleanup . "$err") if ($err);
1325 $self->{OUT} = $out;
1327 my $numbytes = (-s $self->{tmpfile});
1328 open(IN, $self->{tmpfile})
1329 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1331 $self->{copies} = 1 unless $self->{media} eq 'printer';
1333 chdir("$self->{cwd}");
1334 #print(STDERR "Kopien $self->{copies}\n");
1335 #print(STDERR "OUT $self->{OUT}\n");
1336 for my $i (1 .. $self->{copies}) {
1338 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1339 print OUT while <IN>;
1344 $self->{attachment_filename} = ($self->{attachment_filename})
1345 ? $self->{attachment_filename}
1346 : $self->generate_attachment_filename();
1348 # launch application
1349 print qq|Content-Type: | . $template->get_mime_type() . qq|
1350 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1351 Content-Length: $numbytes
1355 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1366 chdir("$self->{cwd}");
1367 $main::lxdebug->leave_sub();
1370 sub get_formname_translation {
1371 $main::lxdebug->enter_sub();
1372 my ($self, $formname) = @_;
1374 $formname ||= $self->{formname};
1376 my %formname_translations = (
1377 bin_list => $main::locale->text('Bin List'),
1378 credit_note => $main::locale->text('Credit Note'),
1379 invoice => $main::locale->text('Invoice'),
1380 pick_list => $main::locale->text('Pick List'),
1381 proforma => $main::locale->text('Proforma Invoice'),
1382 purchase_order => $main::locale->text('Purchase Order'),
1383 request_quotation => $main::locale->text('RFQ'),
1384 sales_order => $main::locale->text('Confirmation'),
1385 sales_quotation => $main::locale->text('Quotation'),
1386 storno_invoice => $main::locale->text('Storno Invoice'),
1387 sales_delivery_order => $main::locale->text('Delivery Order'),
1388 purchase_delivery_order => $main::locale->text('Delivery Order'),
1389 dunning => $main::locale->text('Dunning'),
1392 $main::lxdebug->leave_sub();
1393 return $formname_translations{$formname}
1396 sub get_number_prefix_for_type {
1397 $main::lxdebug->enter_sub();
1401 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1402 : ($self->{type} =~ /_quotation$/) ? 'quo'
1403 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1406 $main::lxdebug->leave_sub();
1410 sub get_extension_for_format {
1411 $main::lxdebug->enter_sub();
1414 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1415 : $self->{format} =~ /postscript/i ? ".ps"
1416 : $self->{format} =~ /opendocument/i ? ".odt"
1417 : $self->{format} =~ /excel/i ? ".xls"
1418 : $self->{format} =~ /html/i ? ".html"
1421 $main::lxdebug->leave_sub();
1425 sub generate_attachment_filename {
1426 $main::lxdebug->enter_sub();
1429 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1430 my $prefix = $self->get_number_prefix_for_type();
1432 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1433 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1435 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1436 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1439 $attachment_filename = "";
1442 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1443 $attachment_filename =~ s|[\s/\\]+|_|g;
1445 $main::lxdebug->leave_sub();
1446 return $attachment_filename;
1449 sub generate_email_subject {
1450 $main::lxdebug->enter_sub();
1453 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1454 my $prefix = $self->get_number_prefix_for_type();
1456 if ($subject && $self->{"${prefix}number"}) {
1457 $subject .= " " . $self->{"${prefix}number"}
1460 $main::lxdebug->leave_sub();
1465 $main::lxdebug->enter_sub();
1469 chdir("$self->{tmpdir}");
1472 if (-f "$self->{tmpfile}.err") {
1473 open(FH, "$self->{tmpfile}.err");
1478 if ($self->{tmpfile} && ! $::keep_temp_files) {
1479 $self->{tmpfile} =~ s|.*/||g;
1481 $self->{tmpfile} =~ s/\.\w+$//g;
1482 my $tmpfile = $self->{tmpfile};
1483 unlink(<$tmpfile.*>);
1486 chdir("$self->{cwd}");
1488 $main::lxdebug->leave_sub();
1494 $main::lxdebug->enter_sub();
1496 my ($self, $date, $myconfig) = @_;
1499 if ($date && $date =~ /\D/) {
1501 if ($myconfig->{dateformat} =~ /^yy/) {
1502 ($yy, $mm, $dd) = split /\D/, $date;
1504 if ($myconfig->{dateformat} =~ /^mm/) {
1505 ($mm, $dd, $yy) = split /\D/, $date;
1507 if ($myconfig->{dateformat} =~ /^dd/) {
1508 ($dd, $mm, $yy) = split /\D/, $date;
1513 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1514 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1516 $dd = "0$dd" if ($dd < 10);
1517 $mm = "0$mm" if ($mm < 10);
1519 $date = "$yy$mm$dd";
1522 $main::lxdebug->leave_sub();
1527 # Database routines used throughout
1529 sub _dbconnect_options {
1531 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1538 $main::lxdebug->enter_sub(2);
1540 my ($self, $myconfig) = @_;
1542 # connect to database
1543 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1547 if ($myconfig->{dboptions}) {
1548 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1551 $main::lxdebug->leave_sub(2);
1556 sub dbconnect_noauto {
1557 $main::lxdebug->enter_sub();
1559 my ($self, $myconfig) = @_;
1561 # connect to database
1562 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1566 if ($myconfig->{dboptions}) {
1567 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1570 $main::lxdebug->leave_sub();
1575 sub get_standard_dbh {
1576 $main::lxdebug->enter_sub(2);
1579 my $myconfig = shift || \%::myconfig;
1581 if ($standard_dbh && !$standard_dbh->{Active}) {
1582 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1583 undef $standard_dbh;
1586 $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1588 $main::lxdebug->leave_sub(2);
1590 return $standard_dbh;
1594 $main::lxdebug->enter_sub();
1596 my ($self, $date, $myconfig) = @_;
1597 my $dbh = $self->dbconnect($myconfig);
1599 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1600 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1601 my ($closed) = $sth->fetchrow_array;
1603 $main::lxdebug->leave_sub();
1608 sub update_balance {
1609 $main::lxdebug->enter_sub();
1611 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1613 # if we have a value, go do it
1616 # retrieve balance from table
1617 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1618 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1619 my ($balance) = $sth->fetchrow_array;
1625 $query = "UPDATE $table SET $field = $balance WHERE $where";
1626 do_query($self, $dbh, $query, @values);
1628 $main::lxdebug->leave_sub();
1631 sub update_exchangerate {
1632 $main::lxdebug->enter_sub();
1634 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1636 # some sanity check for currency
1638 $main::lxdebug->leave_sub();
1641 $query = qq|SELECT curr FROM defaults|;
1643 my ($currency) = selectrow_query($self, $dbh, $query);
1644 my ($defaultcurrency) = split m/:/, $currency;
1647 if ($curr eq $defaultcurrency) {
1648 $main::lxdebug->leave_sub();
1652 $query = qq|SELECT e.curr FROM exchangerate e
1653 WHERE e.curr = ? AND e.transdate = ?
1655 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1664 $buy = conv_i($buy, "NULL");
1665 $sell = conv_i($sell, "NULL");
1668 if ($buy != 0 && $sell != 0) {
1669 $set = "buy = $buy, sell = $sell";
1670 } elsif ($buy != 0) {
1671 $set = "buy = $buy";
1672 } elsif ($sell != 0) {
1673 $set = "sell = $sell";
1676 if ($sth->fetchrow_array) {
1677 $query = qq|UPDATE exchangerate
1683 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1684 VALUES (?, $buy, $sell, ?)|;
1687 do_query($self, $dbh, $query, $curr, $transdate);
1689 $main::lxdebug->leave_sub();
1692 sub save_exchangerate {
1693 $main::lxdebug->enter_sub();
1695 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1697 my $dbh = $self->dbconnect($myconfig);
1701 $buy = $rate if $fld eq 'buy';
1702 $sell = $rate if $fld eq 'sell';
1705 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1710 $main::lxdebug->leave_sub();
1713 sub get_exchangerate {
1714 $main::lxdebug->enter_sub();
1716 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1719 unless ($transdate) {
1720 $main::lxdebug->leave_sub();
1724 $query = qq|SELECT curr FROM defaults|;
1726 my ($currency) = selectrow_query($self, $dbh, $query);
1727 my ($defaultcurrency) = split m/:/, $currency;
1729 if ($currency eq $defaultcurrency) {
1730 $main::lxdebug->leave_sub();
1734 $query = qq|SELECT e.$fld FROM exchangerate e
1735 WHERE e.curr = ? AND e.transdate = ?|;
1736 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1740 $main::lxdebug->leave_sub();
1742 return $exchangerate;
1745 sub check_exchangerate {
1746 $main::lxdebug->enter_sub();
1748 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1750 if ($fld !~/^buy|sell$/) {
1751 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1754 unless ($transdate) {
1755 $main::lxdebug->leave_sub();
1759 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1761 if ($currency eq $defaultcurrency) {
1762 $main::lxdebug->leave_sub();
1766 my $dbh = $self->get_standard_dbh($myconfig);
1767 my $query = qq|SELECT e.$fld FROM exchangerate e
1768 WHERE e.curr = ? AND e.transdate = ?|;
1770 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1772 $main::lxdebug->leave_sub();
1774 return $exchangerate;
1777 sub get_all_currencies {
1778 $main::lxdebug->enter_sub();
1781 my $myconfig = shift || \%::myconfig;
1782 my $dbh = $self->get_standard_dbh($myconfig);
1784 my $query = qq|SELECT curr FROM defaults|;
1786 my ($curr) = selectrow_query($self, $dbh, $query);
1787 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1789 $main::lxdebug->leave_sub();
1794 sub get_default_currency {
1795 $main::lxdebug->enter_sub();
1797 my ($self, $myconfig) = @_;
1798 my @currencies = $self->get_all_currencies($myconfig);
1800 $main::lxdebug->leave_sub();
1802 return $currencies[0];
1805 sub set_payment_options {
1806 $main::lxdebug->enter_sub();
1808 my ($self, $myconfig, $transdate) = @_;
1810 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1812 my $dbh = $self->get_standard_dbh($myconfig);
1815 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1816 qq|FROM payment_terms p | .
1819 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1820 $self->{payment_terms}) =
1821 selectrow_query($self, $dbh, $query, $self->{payment_id});
1823 if ($transdate eq "") {
1824 if ($self->{invdate}) {
1825 $transdate = $self->{invdate};
1827 $transdate = $self->{transdate};
1832 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1833 qq|FROM payment_terms|;
1834 ($self->{netto_date}, $self->{skonto_date}) =
1835 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1837 my ($invtotal, $total);
1838 my (%amounts, %formatted_amounts);
1840 if ($self->{type} =~ /_order$/) {
1841 $amounts{invtotal} = $self->{ordtotal};
1842 $amounts{total} = $self->{ordtotal};
1844 } elsif ($self->{type} =~ /_quotation$/) {
1845 $amounts{invtotal} = $self->{quototal};
1846 $amounts{total} = $self->{quototal};
1849 $amounts{invtotal} = $self->{invtotal};
1850 $amounts{total} = $self->{total};
1852 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1854 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1856 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1857 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1858 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1860 foreach (keys %amounts) {
1861 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1862 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1865 if ($self->{"language_id"}) {
1867 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1868 qq|FROM translation_payment_terms t | .
1869 qq|LEFT JOIN language l ON t.language_id = l.id | .
1870 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1871 my ($description_long, $output_numberformat, $output_dateformat,
1872 $output_longdates) =
1873 selectrow_query($self, $dbh, $query,
1874 $self->{"language_id"}, $self->{"payment_id"});
1876 $self->{payment_terms} = $description_long if ($description_long);
1878 if ($output_dateformat) {
1879 foreach my $key (qw(netto_date skonto_date)) {
1881 $main::locale->reformat_date($myconfig, $self->{$key},
1887 if ($output_numberformat &&
1888 ($output_numberformat ne $myconfig->{"numberformat"})) {
1889 my $saved_numberformat = $myconfig->{"numberformat"};
1890 $myconfig->{"numberformat"} = $output_numberformat;
1891 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1892 $myconfig->{"numberformat"} = $saved_numberformat;
1896 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1897 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1898 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1899 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1900 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1901 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1902 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1904 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1906 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1908 $main::lxdebug->leave_sub();
1912 sub get_template_language {
1913 $main::lxdebug->enter_sub();
1915 my ($self, $myconfig) = @_;
1917 my $template_code = "";
1919 if ($self->{language_id}) {
1920 my $dbh = $self->get_standard_dbh($myconfig);
1921 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1922 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1925 $main::lxdebug->leave_sub();
1927 return $template_code;
1930 sub get_printer_code {
1931 $main::lxdebug->enter_sub();
1933 my ($self, $myconfig) = @_;
1935 my $template_code = "";
1937 if ($self->{printer_id}) {
1938 my $dbh = $self->get_standard_dbh($myconfig);
1939 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1940 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1943 $main::lxdebug->leave_sub();
1945 return $template_code;
1949 $main::lxdebug->enter_sub();
1951 my ($self, $myconfig) = @_;
1953 my $template_code = "";
1955 if ($self->{shipto_id}) {
1956 my $dbh = $self->get_standard_dbh($myconfig);
1957 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1958 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1959 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1962 $main::lxdebug->leave_sub();
1966 $main::lxdebug->enter_sub();
1968 my ($self, $dbh, $id, $module) = @_;
1973 foreach my $item (qw(name department_1 department_2 street zipcode city country
1974 contact cp_gender phone fax email)) {
1975 if ($self->{"shipto$item"}) {
1976 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1978 push(@values, $self->{"shipto${item}"});
1982 if ($self->{shipto_id}) {
1983 my $query = qq|UPDATE shipto set
1985 shiptodepartment_1 = ?,
1986 shiptodepartment_2 = ?,
1992 shiptocp_gender = ?,
1996 WHERE shipto_id = ?|;
1997 do_query($self, $dbh, $query, @values, $self->{shipto_id});
1999 my $query = qq|SELECT * FROM shipto
2000 WHERE shiptoname = ? AND
2001 shiptodepartment_1 = ? AND
2002 shiptodepartment_2 = ? AND
2003 shiptostreet = ? AND
2004 shiptozipcode = ? AND
2006 shiptocountry = ? AND
2007 shiptocontact = ? AND
2008 shiptocp_gender = ? AND
2014 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2017 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2018 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2019 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2020 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2021 do_query($self, $dbh, $query, $id, @values, $module);
2026 $main::lxdebug->leave_sub();
2030 $main::lxdebug->enter_sub();
2032 my ($self, $dbh) = @_;
2034 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2036 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2037 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2038 $self->{"employee_id"} *= 1;
2040 $main::lxdebug->leave_sub();
2043 sub get_employee_data {
2044 $main::lxdebug->enter_sub();
2049 Common::check_params(\%params, qw(prefix));
2050 Common::check_params_x(\%params, qw(id));
2053 $main::lxdebug->leave_sub();
2057 my $myconfig = \%main::myconfig;
2058 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2060 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2063 my $user = User->new($login);
2064 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2066 $self->{$params{prefix} . '_login'} = $login;
2067 $self->{$params{prefix} . '_name'} ||= $login;
2070 $main::lxdebug->leave_sub();
2074 $main::lxdebug->enter_sub();
2076 my ($self, $myconfig, $reference_date) = @_;
2078 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2080 my $dbh = $self->get_standard_dbh($myconfig);
2081 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2082 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2084 $main::lxdebug->leave_sub();
2090 $main::lxdebug->enter_sub();
2092 my ($self, $dbh, $id, $key) = @_;
2094 $key = "all_contacts" unless ($key);
2098 $main::lxdebug->leave_sub();
2103 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2104 qq|FROM contacts | .
2105 qq|WHERE cp_cv_id = ? | .
2106 qq|ORDER BY lower(cp_name)|;
2108 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2110 $main::lxdebug->leave_sub();
2114 $main::lxdebug->enter_sub();
2116 my ($self, $dbh, $key) = @_;
2118 my ($all, $old_id, $where, @values);
2120 if (ref($key) eq "HASH") {
2123 $key = "ALL_PROJECTS";
2125 foreach my $p (keys(%{$params})) {
2127 $all = $params->{$p};
2128 } elsif ($p eq "old_id") {
2129 $old_id = $params->{$p};
2130 } elsif ($p eq "key") {
2131 $key = $params->{$p};
2137 $where = "WHERE active ";
2139 if (ref($old_id) eq "ARRAY") {
2140 my @ids = grep({ $_ } @{$old_id});
2142 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2143 push(@values, @ids);
2146 $where .= " OR (id = ?) ";
2147 push(@values, $old_id);
2153 qq|SELECT id, projectnumber, description, active | .
2156 qq|ORDER BY lower(projectnumber)|;
2158 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2160 $main::lxdebug->leave_sub();
2164 $main::lxdebug->enter_sub();
2166 my ($self, $dbh, $vc_id, $key) = @_;
2168 $key = "all_shipto" unless ($key);
2171 # get shipping addresses
2172 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2174 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2180 $main::lxdebug->leave_sub();
2184 $main::lxdebug->enter_sub();
2186 my ($self, $dbh, $key) = @_;
2188 $key = "all_printers" unless ($key);
2190 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2192 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2194 $main::lxdebug->leave_sub();
2198 $main::lxdebug->enter_sub();
2200 my ($self, $dbh, $params) = @_;
2203 $key = $params->{key};
2204 $key = "all_charts" unless ($key);
2206 my $transdate = quote_db_date($params->{transdate});
2209 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2211 qq|LEFT JOIN taxkeys tk ON | .
2212 qq|(tk.id = (SELECT id FROM taxkeys | .
2213 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2214 qq| ORDER BY startdate DESC LIMIT 1)) | .
2215 qq|ORDER BY c.accno|;
2217 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2219 $main::lxdebug->leave_sub();
2222 sub _get_taxcharts {
2223 $main::lxdebug->enter_sub();
2225 my ($self, $dbh, $params) = @_;
2227 my $key = "all_taxcharts";
2230 if (ref $params eq 'HASH') {
2231 $key = $params->{key} if ($params->{key});
2232 if ($params->{module} eq 'AR') {
2233 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2235 } elsif ($params->{module} eq 'AP') {
2236 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2243 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2245 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2247 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2249 $main::lxdebug->leave_sub();
2253 $main::lxdebug->enter_sub();
2255 my ($self, $dbh, $key) = @_;
2257 $key = "all_taxzones" unless ($key);
2259 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2261 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2263 $main::lxdebug->leave_sub();
2266 sub _get_employees {
2267 $main::lxdebug->enter_sub();
2269 my ($self, $dbh, $default_key, $key) = @_;
2271 $key = $default_key unless ($key);
2272 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2274 $main::lxdebug->leave_sub();
2277 sub _get_business_types {
2278 $main::lxdebug->enter_sub();
2280 my ($self, $dbh, $key) = @_;
2282 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2283 $options->{key} ||= "all_business_types";
2286 if (exists $options->{salesman}) {
2287 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2290 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2292 $main::lxdebug->leave_sub();
2295 sub _get_languages {
2296 $main::lxdebug->enter_sub();
2298 my ($self, $dbh, $key) = @_;
2300 $key = "all_languages" unless ($key);
2302 my $query = qq|SELECT * FROM language ORDER BY id|;
2304 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2306 $main::lxdebug->leave_sub();
2309 sub _get_dunning_configs {
2310 $main::lxdebug->enter_sub();
2312 my ($self, $dbh, $key) = @_;
2314 $key = "all_dunning_configs" unless ($key);
2316 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2318 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2320 $main::lxdebug->leave_sub();
2323 sub _get_currencies {
2324 $main::lxdebug->enter_sub();
2326 my ($self, $dbh, $key) = @_;
2328 $key = "all_currencies" unless ($key);
2330 my $query = qq|SELECT curr AS currency FROM defaults|;
2332 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2334 $main::lxdebug->leave_sub();
2338 $main::lxdebug->enter_sub();
2340 my ($self, $dbh, $key) = @_;
2342 $key = "all_payments" unless ($key);
2344 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2346 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2348 $main::lxdebug->leave_sub();
2351 sub _get_customers {
2352 $main::lxdebug->enter_sub();
2354 my ($self, $dbh, $key) = @_;
2356 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2357 $options->{key} ||= "all_customers";
2358 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2361 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2362 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2363 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2365 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2366 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2368 $main::lxdebug->leave_sub();
2372 $main::lxdebug->enter_sub();
2374 my ($self, $dbh, $key) = @_;
2376 $key = "all_vendors" unless ($key);
2378 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2380 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2382 $main::lxdebug->leave_sub();
2385 sub _get_departments {
2386 $main::lxdebug->enter_sub();
2388 my ($self, $dbh, $key) = @_;
2390 $key = "all_departments" unless ($key);
2392 my $query = qq|SELECT * FROM department ORDER BY description|;
2394 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2396 $main::lxdebug->leave_sub();
2399 sub _get_warehouses {
2400 $main::lxdebug->enter_sub();
2402 my ($self, $dbh, $param) = @_;
2404 my ($key, $bins_key);
2406 if ('' eq ref $param) {
2410 $key = $param->{key};
2411 $bins_key = $param->{bins};
2414 my $query = qq|SELECT w.* FROM warehouse w
2415 WHERE (NOT w.invalid) AND
2416 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2417 ORDER BY w.sortkey|;
2419 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2422 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2423 my $sth = prepare_query($self, $dbh, $query);
2425 foreach my $warehouse (@{ $self->{$key} }) {
2426 do_statement($self, $sth, $query, $warehouse->{id});
2427 $warehouse->{$bins_key} = [];
2429 while (my $ref = $sth->fetchrow_hashref()) {
2430 push @{ $warehouse->{$bins_key} }, $ref;
2436 $main::lxdebug->leave_sub();
2440 $main::lxdebug->enter_sub();
2442 my ($self, $dbh, $table, $key, $sortkey) = @_;
2444 my $query = qq|SELECT * FROM $table|;
2445 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2447 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2449 $main::lxdebug->leave_sub();
2453 # $main::lxdebug->enter_sub();
2455 # my ($self, $dbh, $key) = @_;
2457 # $key ||= "all_groups";
2459 # my $groups = $main::auth->read_groups();
2461 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2463 # $main::lxdebug->leave_sub();
2467 $main::lxdebug->enter_sub();
2472 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2473 my ($sth, $query, $ref);
2475 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2476 my $vc_id = $self->{"${vc}_id"};
2478 if ($params{"contacts"}) {
2479 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2482 if ($params{"shipto"}) {
2483 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2486 if ($params{"projects"} || $params{"all_projects"}) {
2487 $self->_get_projects($dbh, $params{"all_projects"} ?
2488 $params{"all_projects"} : $params{"projects"},
2489 $params{"all_projects"} ? 1 : 0);
2492 if ($params{"printers"}) {
2493 $self->_get_printers($dbh, $params{"printers"});
2496 if ($params{"languages"}) {
2497 $self->_get_languages($dbh, $params{"languages"});
2500 if ($params{"charts"}) {
2501 $self->_get_charts($dbh, $params{"charts"});
2504 if ($params{"taxcharts"}) {
2505 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2508 if ($params{"taxzones"}) {
2509 $self->_get_taxzones($dbh, $params{"taxzones"});
2512 if ($params{"employees"}) {
2513 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2516 if ($params{"salesmen"}) {
2517 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2520 if ($params{"business_types"}) {
2521 $self->_get_business_types($dbh, $params{"business_types"});
2524 if ($params{"dunning_configs"}) {
2525 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2528 if($params{"currencies"}) {
2529 $self->_get_currencies($dbh, $params{"currencies"});
2532 if($params{"customers"}) {
2533 $self->_get_customers($dbh, $params{"customers"});
2536 if($params{"vendors"}) {
2537 if (ref $params{"vendors"} eq 'HASH') {
2538 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2540 $self->_get_vendors($dbh, $params{"vendors"});
2544 if($params{"payments"}) {
2545 $self->_get_payments($dbh, $params{"payments"});
2548 if($params{"departments"}) {
2549 $self->_get_departments($dbh, $params{"departments"});
2552 if ($params{price_factors}) {
2553 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2556 if ($params{warehouses}) {
2557 $self->_get_warehouses($dbh, $params{warehouses});
2560 # if ($params{groups}) {
2561 # $self->_get_groups($dbh, $params{groups});
2564 if ($params{partsgroup}) {
2565 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2568 $main::lxdebug->leave_sub();
2571 # this sub gets the id and name from $table
2573 $main::lxdebug->enter_sub();
2575 my ($self, $myconfig, $table) = @_;
2577 # connect to database
2578 my $dbh = $self->get_standard_dbh($myconfig);
2580 $table = $table eq "customer" ? "customer" : "vendor";
2581 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2583 my ($query, @values);
2585 if (!$self->{openinvoices}) {
2587 if ($self->{customernumber} ne "") {
2588 $where = qq|(vc.customernumber ILIKE ?)|;
2589 push(@values, '%' . $self->{customernumber} . '%');
2591 $where = qq|(vc.name ILIKE ?)|;
2592 push(@values, '%' . $self->{$table} . '%');
2596 qq~SELECT vc.id, vc.name,
2597 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2599 WHERE $where AND (NOT vc.obsolete)
2603 qq~SELECT DISTINCT vc.id, vc.name,
2604 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2606 JOIN $table vc ON (a.${table}_id = vc.id)
2607 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2609 push(@values, '%' . $self->{$table} . '%');
2612 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2614 $main::lxdebug->leave_sub();
2616 return scalar(@{ $self->{name_list} });
2619 # the selection sub is used in the AR, AP, IS, IR and OE module
2622 $main::lxdebug->enter_sub();
2624 my ($self, $myconfig, $table, $module) = @_;
2627 my $dbh = $self->get_standard_dbh;
2629 $table = $table eq "customer" ? "customer" : "vendor";
2631 my $query = qq|SELECT count(*) FROM $table|;
2632 my ($count) = selectrow_query($self, $dbh, $query);
2634 # build selection list
2635 if ($count <= $myconfig->{vclimit}) {
2636 $query = qq|SELECT id, name, salesman_id
2637 FROM $table WHERE NOT obsolete
2639 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2643 $self->get_employee($dbh);
2645 # setup sales contacts
2646 $query = qq|SELECT e.id, e.name
2648 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2649 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2652 push(@{ $self->{all_employees} },
2653 { id => $self->{employee_id},
2654 name => $self->{employee} });
2656 # sort the whole thing
2657 @{ $self->{all_employees} } =
2658 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2660 if ($module eq 'AR') {
2662 # prepare query for departments
2663 $query = qq|SELECT id, description
2666 ORDER BY description|;
2669 $query = qq|SELECT id, description
2671 ORDER BY description|;
2674 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2677 $query = qq|SELECT id, description
2681 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2684 $query = qq|SELECT printer_description, id
2686 ORDER BY printer_description|;
2688 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2691 $query = qq|SELECT id, description
2695 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2697 $main::lxdebug->leave_sub();
2700 sub language_payment {
2701 $main::lxdebug->enter_sub();
2703 my ($self, $myconfig) = @_;
2705 my $dbh = $self->get_standard_dbh($myconfig);
2707 my $query = qq|SELECT id, description
2711 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2714 $query = qq|SELECT printer_description, id
2716 ORDER BY printer_description|;
2718 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2721 $query = qq|SELECT id, description
2725 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2727 # get buchungsgruppen
2728 $query = qq|SELECT id, description
2729 FROM buchungsgruppen|;
2731 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2733 $main::lxdebug->leave_sub();
2736 # this is only used for reports
2737 sub all_departments {
2738 $main::lxdebug->enter_sub();
2740 my ($self, $myconfig, $table) = @_;
2742 my $dbh = $self->get_standard_dbh($myconfig);
2745 if ($table eq 'customer') {
2746 $where = "WHERE role = 'P' ";
2749 my $query = qq|SELECT id, description
2752 ORDER BY description|;
2753 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2755 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2757 $main::lxdebug->leave_sub();
2761 $main::lxdebug->enter_sub();
2763 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2766 if ($table eq "customer") {
2775 $self->all_vc($myconfig, $table, $module);
2777 # get last customers or vendors
2778 my ($query, $sth, $ref);
2780 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2785 my $transdate = "current_date";
2786 if ($self->{transdate}) {
2787 $transdate = $dbh->quote($self->{transdate});
2790 # now get the account numbers
2791 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2792 FROM chart c, taxkeys tk
2793 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2794 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2797 $sth = $dbh->prepare($query);
2799 do_statement($self, $sth, $query, '%' . $module . '%');
2801 $self->{accounts} = "";
2802 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2804 foreach my $key (split(/:/, $ref->{link})) {
2805 if ($key =~ /\Q$module\E/) {
2807 # cross reference for keys
2808 $xkeyref{ $ref->{accno} } = $key;
2810 push @{ $self->{"${module}_links"}{$key} },
2811 { accno => $ref->{accno},
2812 description => $ref->{description},
2813 taxkey => $ref->{taxkey_id},
2814 tax_id => $ref->{tax_id} };
2816 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2822 # get taxkeys and description
2823 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2824 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2826 if (($module eq "AP") || ($module eq "AR")) {
2827 # get tax rates and description
2828 $query = qq|SELECT * FROM tax|;
2829 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2835 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2836 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2837 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2838 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2840 d.description AS department,
2843 JOIN $table c ON (a.${table}_id = c.id)
2844 LEFT JOIN employee e ON (e.id = a.employee_id)
2845 LEFT JOIN department d ON (d.id = a.department_id)
2847 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2849 foreach my $key (keys %$ref) {
2850 $self->{$key} = $ref->{$key};
2853 my $transdate = "current_date";
2854 if ($self->{transdate}) {
2855 $transdate = $dbh->quote($self->{transdate});
2858 # now get the account numbers
2859 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2861 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2863 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2864 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2867 $sth = $dbh->prepare($query);
2868 do_statement($self, $sth, $query, "%$module%");
2870 $self->{accounts} = "";
2871 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2873 foreach my $key (split(/:/, $ref->{link})) {
2874 if ($key =~ /\Q$module\E/) {
2876 # cross reference for keys
2877 $xkeyref{ $ref->{accno} } = $key;
2879 push @{ $self->{"${module}_links"}{$key} },
2880 { accno => $ref->{accno},
2881 description => $ref->{description},
2882 taxkey => $ref->{taxkey_id},
2883 tax_id => $ref->{tax_id} };
2885 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2891 # get amounts from individual entries
2894 c.accno, c.description,
2895 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2899 LEFT JOIN chart c ON (c.id = a.chart_id)
2900 LEFT JOIN project p ON (p.id = a.project_id)
2901 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2902 WHERE (tk.taxkey_id=a.taxkey) AND
2903 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2904 THEN tk.chart_id = a.chart_id
2907 OR (c.link='%tax%')) AND
2908 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2909 WHERE a.trans_id = ?
2910 AND a.fx_transaction = '0'
2911 ORDER BY a.acc_trans_id, a.transdate|;
2912 $sth = $dbh->prepare($query);
2913 do_statement($self, $sth, $query, $self->{id});
2915 # get exchangerate for currency
2916 $self->{exchangerate} =
2917 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2920 # store amounts in {acc_trans}{$key} for multiple accounts
2921 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2922 $ref->{exchangerate} =
2923 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2924 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2927 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2928 $ref->{amount} *= -1;
2930 $ref->{index} = $index;
2932 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2938 d.curr AS currencies, d.closedto, d.revtrans,
2939 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2940 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2942 $ref = selectfirst_hashref_query($self, $dbh, $query);
2943 map { $self->{$_} = $ref->{$_} } keys %$ref;
2950 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2951 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2952 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2954 $ref = selectfirst_hashref_query($self, $dbh, $query);
2955 map { $self->{$_} = $ref->{$_} } keys %$ref;
2957 if ($self->{"$self->{vc}_id"}) {
2959 # only setup currency
2960 ($self->{currency}) = split(/:/, $self->{currencies});
2964 $self->lastname_used($dbh, $myconfig, $table, $module);
2966 # get exchangerate for currency
2967 $self->{exchangerate} =
2968 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2974 $main::lxdebug->leave_sub();
2978 $main::lxdebug->enter_sub();
2980 my ($self, $dbh, $myconfig, $table, $module) = @_;
2984 $table = $table eq "customer" ? "customer" : "vendor";
2985 my %column_map = ("a.curr" => "currency",
2986 "a.${table}_id" => "${table}_id",
2987 "a.department_id" => "department_id",
2988 "d.description" => "department",
2989 "ct.name" => $table,
2990 "current_date + ct.terms" => "duedate",
2993 if ($self->{type} =~ /delivery_order/) {
2994 $arap = 'delivery_orders';
2995 delete $column_map{"a.curr"};
2997 } elsif ($self->{type} =~ /_order/) {
2999 $where = "quotation = '0'";
3001 } elsif ($self->{type} =~ /_quotation/) {
3003 $where = "quotation = '1'";
3005 } elsif ($table eq 'customer') {
3013 $where = "($where) AND" if ($where);
3014 my $query = qq|SELECT MAX(id) FROM $arap
3015 WHERE $where ${table}_id > 0|;
3016 my ($trans_id) = selectrow_query($self, $dbh, $query);
3019 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3020 $query = qq|SELECT $column_spec
3022 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3023 LEFT JOIN department d ON (a.department_id = d.id)
3025 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3027 map { $self->{$_} = $ref->{$_} } values %column_map;
3029 $main::lxdebug->leave_sub();
3033 $main::lxdebug->enter_sub();
3036 my $myconfig = shift || \%::myconfig;
3037 my ($thisdate, $days) = @_;
3039 my $dbh = $self->get_standard_dbh($myconfig);
3044 my $dateformat = $myconfig->{dateformat};
3045 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3046 $thisdate = $dbh->quote($thisdate);
3047 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3049 $query = qq|SELECT current_date AS thisdate|;
3052 ($thisdate) = selectrow_query($self, $dbh, $query);
3054 $main::lxdebug->leave_sub();
3060 $main::lxdebug->enter_sub();
3062 my ($self, $string) = @_;
3064 if ($string !~ /%/) {
3065 $string = "%$string%";
3068 $string =~ s/\'/\'\'/g;
3070 $main::lxdebug->leave_sub();
3076 $main::lxdebug->enter_sub();
3078 my ($self, $flds, $new, $count, $numrows) = @_;
3082 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3087 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3089 my $j = $item->{ndx} - 1;
3090 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3094 for $i ($count + 1 .. $numrows) {
3095 map { delete $self->{"${_}_$i"} } @{$flds};
3098 $main::lxdebug->leave_sub();
3102 $main::lxdebug->enter_sub();
3104 my ($self, $myconfig) = @_;
3108 my $dbh = $self->dbconnect_noauto($myconfig);
3110 my $query = qq|DELETE FROM status
3111 WHERE (formname = ?) AND (trans_id = ?)|;
3112 my $sth = prepare_query($self, $dbh, $query);
3114 if ($self->{formname} =~ /(check|receipt)/) {
3115 for $i (1 .. $self->{rowcount}) {
3116 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3119 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3123 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3124 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3126 my %queued = split / /, $self->{queued};
3129 if ($self->{formname} =~ /(check|receipt)/) {
3131 # this is a check or receipt, add one entry for each lineitem
3132 my ($accno) = split /--/, $self->{account};
3133 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3134 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3135 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3136 $sth = prepare_query($self, $dbh, $query);
3138 for $i (1 .. $self->{rowcount}) {
3139 if ($self->{"checked_$i"}) {
3140 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3146 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3147 VALUES (?, ?, ?, ?, ?)|;
3148 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3149 $queued{$self->{formname}}, $self->{formname});
3155 $main::lxdebug->leave_sub();
3159 $main::lxdebug->enter_sub();
3161 my ($self, $dbh) = @_;
3163 my ($query, $printed, $emailed);
3165 my $formnames = $self->{printed};
3166 my $emailforms = $self->{emailed};
3168 $query = qq|DELETE FROM status
3169 WHERE (formname = ?) AND (trans_id = ?)|;
3170 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3172 # this only applies to the forms
3173 # checks and receipts are posted when printed or queued
3175 if ($self->{queued}) {
3176 my %queued = split / /, $self->{queued};
3178 foreach my $formname (keys %queued) {
3179 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3180 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3182 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3183 VALUES (?, ?, ?, ?, ?)|;
3184 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3186 $formnames =~ s/\Q$self->{formname}\E//;
3187 $emailforms =~ s/\Q$self->{formname}\E//;
3192 # save printed, emailed info
3193 $formnames =~ s/^ +//g;
3194 $emailforms =~ s/^ +//g;
3197 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3198 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3200 foreach my $formname (keys %status) {
3201 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3202 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3204 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3205 VALUES (?, ?, ?, ?)|;
3206 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3209 $main::lxdebug->leave_sub();
3213 # $main::locale->text('SAVED')
3214 # $main::locale->text('DELETED')
3215 # $main::locale->text('ADDED')
3216 # $main::locale->text('PAYMENT POSTED')
3217 # $main::locale->text('POSTED')
3218 # $main::locale->text('POSTED AS NEW')
3219 # $main::locale->text('ELSE')
3220 # $main::locale->text('SAVED FOR DUNNING')
3221 # $main::locale->text('DUNNING STARTED')
3222 # $main::locale->text('PRINTED')
3223 # $main::locale->text('MAILED')
3224 # $main::locale->text('SCREENED')
3225 # $main::locale->text('CANCELED')
3226 # $main::locale->text('invoice')
3227 # $main::locale->text('proforma')
3228 # $main::locale->text('sales_order')
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