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 #======================================================================
60 use List::Util qw(first max min sum);
61 use List::MoreUtils qw(any apply);
68 disconnect_standard_dbh();
71 sub disconnect_standard_dbh {
72 return unless $standard_dbh;
73 $standard_dbh->disconnect();
78 $main::lxdebug->enter_sub(2);
84 my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
89 $curr = \ $self->{ shift @tokens };
93 my $sep = shift @tokens;
94 my $key = shift @tokens;
96 $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]';
97 $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
98 $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
99 $curr = \ $$curr->{$key}
104 $main::lxdebug->leave_sub(2);
110 $main::lxdebug->enter_sub(2);
115 my @pairs = split(/&/, $input);
118 my ($key, $value) = split(/=/, $_, 2);
119 $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key);
122 $main::lxdebug->leave_sub(2);
125 sub _request_to_hash {
126 $main::lxdebug->enter_sub(2);
131 if (!$ENV{'CONTENT_TYPE'}
132 || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
134 $self->_input_to_hash($input);
136 $main::lxdebug->leave_sub(2);
140 my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
142 my $boundary = '--' . $1;
144 foreach my $line (split m/\n/, $input) {
145 last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
147 if (($line eq $boundary) || ($line eq "$boundary\r")) {
148 ${ $previous } =~ s|\r?\n$|| if $previous;
154 $content_type = "text/plain";
161 next unless $boundary_found;
163 if (!$headers_done) {
164 $line =~ s/[\r\n]*$//;
171 if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
172 if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
174 substr $line, $-[0], $+[0] - $-[0], "";
177 if ($line =~ m|name\s*=\s*"(.*?)"|i) {
179 substr $line, $-[0], $+[0] - $-[0], "";
182 $previous = $self->_store_value($name, '') if ($name);
183 $self->{FILENAME} = $filename if ($filename);
188 if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
195 next unless $previous;
197 ${ $previous } .= "${line}\n";
200 ${ $previous } =~ s|\r?\n$|| if $previous;
202 $main::lxdebug->leave_sub(2);
205 sub _recode_recursively {
206 $main::lxdebug->enter_sub();
207 my ($iconv, $param) = @_;
209 if (any { ref $param eq $_ } qw(Form HASH)) {
210 foreach my $key (keys %{ $param }) {
211 if (!ref $param->{$key}) {
212 # Workaround for a bug: converting $param->{$key} directly
213 # leads to 'undef'. I don't know why. Converting a copy works,
215 $param->{$key} = $iconv->convert("" . $param->{$key});
217 _recode_recursively($iconv, $param->{$key});
221 } elsif (ref $param eq 'ARRAY') {
222 foreach my $idx (0 .. scalar(@{ $param }) - 1) {
223 if (!ref $param->[$idx]) {
224 # Workaround for a bug: converting $param->[$idx] directly
225 # leads to 'undef'. I don't know why. Converting a copy works,
227 $param->[$idx] = $iconv->convert("" . $param->[$idx]);
229 _recode_recursively($iconv, $param->[$idx]);
233 $main::lxdebug->leave_sub();
237 $main::lxdebug->enter_sub();
243 if ($LXDebug::watch_form) {
244 require SL::Watchdog;
245 tie %{ $self }, 'SL::Watchdog';
250 $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
251 $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0];
253 if ($ENV{CONTENT_LENGTH}) {
255 read STDIN, $content, $ENV{CONTENT_LENGTH};
256 $self->_request_to_hash($content);
259 my $db_charset = $main::dbcharset;
260 $db_charset ||= Common::DEFAULT_CHARSET;
262 my $encoding = $self->{INPUT_ENCODING} || $db_charset;
263 delete $self->{INPUT_ENCODING};
265 _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self);
267 #$self->{version} = "2.6.1"; # Old hardcoded but secure style
268 open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file
269 $self->{version} = <VERSION_FILE>;
271 $self->{version} =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code.
273 $main::lxdebug->leave_sub();
278 sub _flatten_variables_rec {
279 $main::lxdebug->enter_sub(2);
288 if ('' eq ref $curr->{$key}) {
289 @result = ({ 'key' => $prefix . $key, 'value' => $curr->{$key} });
291 } elsif ('HASH' eq ref $curr->{$key}) {
292 foreach my $hash_key (sort keys %{ $curr->{$key} }) {
293 push @result, $self->_flatten_variables_rec($curr->{$key}, $prefix . $key . '.', $hash_key);
297 foreach my $idx (0 .. scalar @{ $curr->{$key} } - 1) {
298 my $first_array_entry = 1;
300 foreach my $hash_key (sort keys %{ $curr->{$key}->[$idx] }) {
301 push @result, $self->_flatten_variables_rec($curr->{$key}->[$idx], $prefix . $key . ($first_array_entry ? '[+].' : '[].'), $hash_key);
302 $first_array_entry = 0;
307 $main::lxdebug->leave_sub(2);
312 sub flatten_variables {
313 $main::lxdebug->enter_sub(2);
321 push @variables, $self->_flatten_variables_rec($self, '', $_);
324 $main::lxdebug->leave_sub(2);
329 sub flatten_standard_variables {
330 $main::lxdebug->enter_sub(2);
333 my %skip_keys = map { $_ => 1 } (qw(login password header stylesheet titlebar version), @_);
337 foreach (grep { ! $skip_keys{$_} } keys %{ $self }) {
338 push @variables, $self->_flatten_variables_rec($self, '', $_);
341 $main::lxdebug->leave_sub(2);
347 $main::lxdebug->enter_sub();
353 map { print "$_ = $self->{$_}\n" } (sort keys %{$self});
355 $main::lxdebug->leave_sub();
359 $main::lxdebug->enter_sub(2);
362 my $password = $self->{password};
364 $self->{password} = 'X' x 8;
366 local $Data::Dumper::Sortkeys = 1;
367 my $output = Dumper($self);
369 $self->{password} = $password;
371 $main::lxdebug->leave_sub(2);
377 $main::lxdebug->enter_sub(2);
379 my ($self, $str) = @_;
381 $str = Encode::encode('utf-8-strict', $str) if $::locale->is_utf8;
382 $str =~ s/([^a-zA-Z0-9_.-])/sprintf("%%%02x", ord($1))/ge;
384 $main::lxdebug->leave_sub(2);
390 $main::lxdebug->enter_sub(2);
392 my ($self, $str) = @_;
397 $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
399 $main::lxdebug->leave_sub(2);
405 $main::lxdebug->enter_sub();
406 my ($self, $str) = @_;
408 if ($str && !ref($str)) {
409 $str =~ s/\"/"/g;
412 $main::lxdebug->leave_sub();
418 $main::lxdebug->enter_sub();
419 my ($self, $str) = @_;
421 if ($str && !ref($str)) {
422 $str =~ s/"/\"/g;
425 $main::lxdebug->leave_sub();
431 $main::lxdebug->enter_sub();
435 map({ print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_);
437 for (sort keys %$self) {
438 next if (($_ eq "header") || (ref($self->{$_}) ne ""));
439 print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n");
442 $main::lxdebug->leave_sub();
446 $main::lxdebug->enter_sub();
448 $main::lxdebug->show_backtrace();
450 my ($self, $msg) = @_;
451 if ($ENV{HTTP_USER_AGENT}) {
453 $self->show_generic_error($msg);
456 print STDERR "Error: $msg\n";
460 $main::lxdebug->leave_sub();
464 $main::lxdebug->enter_sub();
466 my ($self, $msg) = @_;
468 if ($ENV{HTTP_USER_AGENT}) {
471 if (!$self->{header}) {
477 <p class="message_ok"><b>$msg</b></p>
479 <script type="text/javascript">
481 // If JavaScript is enabled, the whole thing will be reloaded.
482 // The reason is: When one changes his menu setup (HTML / XUL / CSS ...)
483 // it now loads the correct code into the browser instead of do nothing.
484 setTimeout("top.frames.location.href='login.pl'",500);
493 if ($self->{info_function}) {
494 &{ $self->{info_function} }($msg);
500 $main::lxdebug->leave_sub();
503 # calculates the number of rows in a textarea based on the content and column number
504 # can be capped with maxrows
506 $main::lxdebug->enter_sub();
507 my ($self, $str, $cols, $maxrows, $minrows) = @_;
511 my $rows = sum map { int((length() - 2) / $cols) + 1 } split /\r/, $str;
514 $main::lxdebug->leave_sub();
516 return max(min($rows, $maxrows), $minrows);
520 $main::lxdebug->enter_sub();
522 my ($self, $msg) = @_;
524 $self->error("$msg\n" . $DBI::errstr);
526 $main::lxdebug->leave_sub();
530 $main::lxdebug->enter_sub();
532 my ($self, $name, $msg) = @_;
535 foreach my $part (split m/\./, $name) {
536 if (!$curr->{$part} || ($curr->{$part} =~ /^\s*$/)) {
539 $curr = $curr->{$part};
542 $main::lxdebug->leave_sub();
545 sub _get_request_uri {
548 return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
550 my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http';
551 my $port = $ENV{SERVER_PORT} || '';
552 $port = undef if (($scheme eq 'http' ) && ($port == 80))
553 || (($scheme eq 'https') && ($port == 443));
555 my $uri = URI->new("${scheme}://");
556 $uri->scheme($scheme);
558 $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
559 $uri->path_query($ENV{REQUEST_URI});
565 sub _add_to_request_uri {
568 my $relative_new_path = shift;
569 my $request_uri = shift || $self->_get_request_uri;
570 my $relative_new_uri = URI->new($relative_new_path);
571 my @request_segments = $request_uri->path_segments;
573 my $new_uri = $request_uri->clone;
574 $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments);
579 sub create_http_response {
580 $main::lxdebug->enter_sub();
585 my $cgi = $main::cgi;
586 $cgi ||= CGI->new('');
589 if (defined $main::auth) {
590 my $uri = $self->_get_request_uri;
591 my @segments = $uri->path_segments;
593 $uri->path_segments(@segments);
595 my $session_cookie_value = $main::auth->get_session_id();
597 if ($session_cookie_value) {
598 $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
599 '-value' => $session_cookie_value,
600 '-path' => $uri->path,
601 '-secure' => $ENV{HTTPS});
605 my %cgi_params = ('-type' => $params{content_type});
606 $cgi_params{'-charset'} = $params{charset} if ($params{charset});
607 $cgi_params{'-cookie'} = $session_cookie if ($session_cookie);
609 my $output = $cgi->header(%cgi_params);
611 $main::lxdebug->leave_sub();
618 $::lxdebug->enter_sub;
620 # extra code is currently only used by menuv3 and menuv4 to set their css.
621 # it is strongly deprecated, and will be changed in a future version.
622 my ($self, $extra_code) = @_;
623 my $db_charset = $::dbcharset || Common::DEFAULT_CHARSET;
626 $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
628 $self->{favicon} ||= "favicon.ico";
629 $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title};
632 if ($self->{refresh_url} || $self->{refresh_time}) {
633 my $refresh_time = $self->{refresh_time} || 3;
634 my $refresh_url = $self->{refresh_url} || $ENV{REFERER};
635 push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
638 push @header, "<link rel='stylesheet' href='css/$_' type='text/css' title='Lx-Office stylesheet'>"
639 for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets};
641 push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
642 push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
643 push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
644 '<script type="text/javascript" src="js/common.js"></script>',
645 '<style type="text/css">@import url(js/jscalendar/calendar-win2k-1.css);</style>',
646 '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
647 '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
648 '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
649 '<script type="text/javascript" src="js/part_selection.js"></script>';
650 push @header, $self->{javascript} if $self->{javascript};
651 push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
652 push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
653 push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
654 join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title};
656 # if there is a title, we put some JavaScript in to the page, wich writes a
657 # meaningful title-tag for our frameset.
659 if ($self->{title}) {
661 <script type="text/javascript">
663 // Write a meaningful title-tag for our frameset.
664 top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
670 print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
671 print "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01//EN' 'http://www.w3.org/TR/html4/strict.dtd'>\n"
672 if $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/; # Other browsers may choke on menu scripts with DOCTYPE.
676 <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
677 <title>$self->{titlebar}</title>
679 print " $_\n" for @header;
681 <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css" />
682 <meta name="robots" content="noindex,nofollow" />
683 <script type="text/javascript" src="js/highlight_input.js"></script>
684 <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
685 <script type="text/javascript" src="js/tabcontent.js">
687 /***********************************************
688 * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
689 * This notice MUST stay intact for legal use
690 * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
691 ***********************************************/
700 $::lxdebug->leave_sub;
703 sub ajax_response_header {
704 $main::lxdebug->enter_sub();
708 my $db_charset = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
709 my $cgi = $main::cgi || CGI->new('');
710 my $output = $cgi->header('-charset' => $db_charset);
712 $main::lxdebug->leave_sub();
717 sub redirect_header {
721 my $base_uri = $self->_get_request_uri;
722 my $new_uri = URI->new_abs($new_url, $base_uri);
724 die "Headers already sent" if $::self->{header};
727 my $cgi = $main::cgi || CGI->new('');
728 return $cgi->redirect($new_uri);
731 sub set_standard_title {
732 $::lxdebug->enter_sub;
735 $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
736 $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
737 $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
739 $::lxdebug->leave_sub;
742 sub _prepare_html_template {
743 $main::lxdebug->enter_sub();
745 my ($self, $file, $additional_params) = @_;
748 if (!%::myconfig || !$::myconfig{"countrycode"}) {
749 $language = $main::language;
751 $language = $main::myconfig{"countrycode"};
753 $language = "de" unless ($language);
755 if (-f "templates/webpages/${file}.html") {
756 if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
757 my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
758 "Please re-run 'locales.pl' in 'locale/${language}'.";
759 print(qq|<pre>$info</pre>|);
763 $file = "templates/webpages/${file}.html";
766 my $info = "Web page template '${file}' not found.\n";
767 print qq|<pre>$info</pre>|;
771 if ($self->{"DEBUG"}) {
772 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
775 if ($additional_params->{"DEBUG"}) {
776 $additional_params->{"DEBUG"} =
777 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
780 if (%main::myconfig) {
781 $::myconfig{jsc_dateformat} = apply {
785 } $::myconfig{"dateformat"};
786 $additional_params->{"myconfig"} ||= \%::myconfig;
787 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
790 $additional_params->{"conf_dbcharset"} = $::dbcharset;
791 $additional_params->{"conf_webdav"} = $::webdav;
792 $additional_params->{"conf_lizenzen"} = $::lizenzen;
793 $additional_params->{"conf_latex_templates"} = $::latex;
794 $additional_params->{"conf_opendocument_templates"} = $::opendocument_templates;
795 $additional_params->{"conf_vertreter"} = $::vertreter;
796 $additional_params->{"conf_show_best_before"} = $::show_best_before;
797 $additional_params->{"conf_parts_image_css"} = $::parts_image_css;
798 $additional_params->{"conf_parts_listing_images"} = $::parts_listing_images;
799 $additional_params->{"conf_parts_show_image"} = $::parts_show_image;
801 if (%main::debug_options) {
802 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
805 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
806 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
807 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
811 $main::lxdebug->leave_sub();
816 sub parse_html_template {
817 $main::lxdebug->enter_sub();
819 my ($self, $file, $additional_params) = @_;
821 $additional_params ||= { };
823 my $real_file = $self->_prepare_html_template($file, $additional_params);
824 my $template = $self->template || $self->init_template;
826 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
829 $template->process($real_file, $additional_params, \$output) || die $template->error;
831 $main::lxdebug->leave_sub();
839 return if $self->template;
841 return $self->template(Template->new({
846 'PLUGIN_BASE' => 'SL::Template::Plugin',
847 'INCLUDE_PATH' => '.:templates/webpages',
848 'COMPILE_EXT' => '.tcc',
849 'COMPILE_DIR' => $::userspath . '/templates-cache',
855 $self->{template_object} = shift if @_;
856 return $self->{template_object};
859 sub show_generic_error {
860 $main::lxdebug->enter_sub();
862 my ($self, $error, %params) = @_;
865 'title_error' => $params{title},
866 'label_error' => $error,
869 if ($params{action}) {
872 map { delete($self->{$_}); } qw(action);
873 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
875 $add_params->{SHOW_BUTTON} = 1;
876 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
877 $add_params->{VARIABLES} = \@vars;
879 } elsif ($params{back_button}) {
880 $add_params->{SHOW_BACK_BUTTON} = 1;
883 $self->{title} = $params{title} if $params{title};
886 print $self->parse_html_template("generic/error", $add_params);
888 print STDERR "Error: $error\n";
890 $main::lxdebug->leave_sub();
895 sub show_generic_information {
896 $main::lxdebug->enter_sub();
898 my ($self, $text, $title) = @_;
901 'title_information' => $title,
902 'label_information' => $text,
905 $self->{title} = $title if ($title);
908 print $self->parse_html_template("generic/information", $add_params);
910 $main::lxdebug->leave_sub();
915 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
916 # changed it to accept an arbitrary number of triggers - sschoeling
918 $main::lxdebug->enter_sub();
921 my $myconfig = shift;
924 # set dateform for jsscript
927 "dd.mm.yy" => "%d.%m.%Y",
928 "dd-mm-yy" => "%d-%m-%Y",
929 "dd/mm/yy" => "%d/%m/%Y",
930 "mm/dd/yy" => "%m/%d/%Y",
931 "mm-dd-yy" => "%m-%d-%Y",
932 "yyyy-mm-dd" => "%Y-%m-%d",
935 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
936 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
943 inputField : "| . (shift) . qq|",
944 ifFormat :"$ifFormat",
945 align : "| . (shift) . qq|",
946 button : "| . (shift) . qq|"
952 <script type="text/javascript">
953 <!--| . join("", @triggers) . qq|//-->
957 $main::lxdebug->leave_sub();
960 } #end sub write_trigger
963 $main::lxdebug->enter_sub();
965 my ($self, $msg) = @_;
967 if (!$self->{callback}) {
973 # my ($script, $argv) = split(/\?/, $self->{callback}, 2);
974 # $script =~ s|.*/||;
975 # $script =~ s|[^a-zA-Z0-9_\.]||g;
976 # exec("perl", "$script", $argv);
978 print $::form->redirect_header($self->{callback});
980 $main::lxdebug->leave_sub();
983 # sort of columns removed - empty sub
985 $main::lxdebug->enter_sub();
987 my ($self, @columns) = @_;
989 $main::lxdebug->leave_sub();
995 $main::lxdebug->enter_sub(2);
997 my ($self, $myconfig, $amount, $places, $dash) = @_;
1003 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1005 my $neg = ($amount =~ s/^-//);
1006 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1008 if (defined($places) && ($places ne '')) {
1014 my ($actual_places) = ($amount =~ /\.(\d+)/);
1015 $actual_places = length($actual_places);
1016 $places = $actual_places > $places ? $actual_places : $places;
1019 $amount = $self->round_amount($amount, $places);
1022 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1023 my @p = split(/\./, $amount); # split amount at decimal point
1025 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1028 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1031 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1032 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1033 ($neg ? "-$amount" : "$amount" ) ;
1037 $main::lxdebug->leave_sub(2);
1041 sub format_amount_units {
1042 $main::lxdebug->enter_sub();
1047 my $myconfig = \%main::myconfig;
1048 my $amount = $params{amount} * 1;
1049 my $places = $params{places};
1050 my $part_unit_name = $params{part_unit};
1051 my $amount_unit_name = $params{amount_unit};
1052 my $conv_units = $params{conv_units};
1053 my $max_places = $params{max_places};
1055 if (!$part_unit_name) {
1056 $main::lxdebug->leave_sub();
1060 AM->retrieve_all_units();
1061 my $all_units = $main::all_units;
1063 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1064 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1067 if (!scalar @{ $conv_units }) {
1068 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1069 $main::lxdebug->leave_sub();
1073 my $part_unit = $all_units->{$part_unit_name};
1074 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1076 $amount *= $conv_unit->{factor};
1081 foreach my $unit (@$conv_units) {
1082 my $last = $unit->{name} eq $part_unit->{name};
1084 $num = int($amount / $unit->{factor});
1085 $amount -= $num * $unit->{factor};
1088 if ($last ? $amount : $num) {
1089 push @values, { "unit" => $unit->{name},
1090 "amount" => $last ? $amount / $unit->{factor} : $num,
1091 "places" => $last ? $places : 0 };
1098 push @values, { "unit" => $part_unit_name,
1103 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1105 $main::lxdebug->leave_sub();
1111 $main::lxdebug->enter_sub(2);
1116 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1117 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1118 $input =~ s/\#\#/\#/g;
1120 $main::lxdebug->leave_sub(2);
1128 $main::lxdebug->enter_sub(2);
1130 my ($self, $myconfig, $amount) = @_;
1132 if ( ($myconfig->{numberformat} eq '1.000,00')
1133 || ($myconfig->{numberformat} eq '1000,00')) {
1138 if ($myconfig->{numberformat} eq "1'000.00") {
1144 $main::lxdebug->leave_sub(2);
1146 return ($amount * 1);
1150 $main::lxdebug->enter_sub(2);
1152 my ($self, $amount, $places) = @_;
1155 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1157 # Round amounts to eight places before rounding to the requested
1158 # number of places. This gets rid of errors due to internal floating
1159 # point representation.
1160 $amount = $self->round_amount($amount, 8) if $places < 8;
1161 $amount = $amount * (10**($places));
1162 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1164 $main::lxdebug->leave_sub(2);
1166 return $round_amount;
1170 sub parse_template {
1171 $main::lxdebug->enter_sub();
1173 my ($self, $myconfig, $userspath) = @_;
1178 $self->{"cwd"} = getcwd();
1179 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1184 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1185 $template_type = 'OpenDocument';
1186 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1188 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1189 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1190 $template_type = 'LaTeX';
1191 $ext_for_format = 'pdf';
1193 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1194 $template_type = 'HTML';
1195 $ext_for_format = 'html';
1197 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1198 $template_type = 'XML';
1199 $ext_for_format = 'xml';
1201 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1202 $template_type = 'XML';
1204 } elsif ( $self->{"format"} =~ /excel/i ) {
1205 $template_type = 'Excel';
1206 $ext_for_format = 'xls';
1208 } elsif ( defined $self->{'format'}) {
1209 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1211 } elsif ( $self->{'format'} eq '' ) {
1212 $self->error("No Outputformat given: $self->{'format'}");
1214 } else { #Catch the rest
1215 $self->error("Outputformat not defined: $self->{'format'}");
1218 my $template = SL::Template::create(type => $template_type,
1219 file_name => $self->{IN},
1221 myconfig => $myconfig,
1222 userspath => $userspath);
1224 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1225 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1227 if (!$self->{employee_id}) {
1228 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1231 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1233 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1235 # OUT is used for the media, screen, printer, email
1236 # for postscript we store a copy in a temporary file
1238 my $prepend_userspath;
1240 if (!$self->{tmpfile}) {
1241 $self->{tmpfile} = "${fileid}.$self->{IN}";
1242 $prepend_userspath = 1;
1245 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1247 $self->{tmpfile} =~ s|.*/||;
1248 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1249 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1251 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1252 $out = $self->{OUT};
1253 $self->{OUT} = ">$self->{tmpfile}";
1259 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1260 $result = $template->parse(*OUT);
1265 $result = $template->parse(*STDOUT);
1270 $self->error("$self->{IN} : " . $template->get_error());
1273 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1275 if ($self->{media} eq 'email') {
1277 my $mail = new Mailer;
1279 map { $mail->{$_} = $self->{$_} }
1280 qw(cc bcc subject message version format);
1281 $mail->{charset} = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
1282 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1283 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1284 $mail->{fileid} = "$fileid.";
1285 $myconfig->{signature} =~ s/\r//g;
1287 # if we send html or plain text inline
1288 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1289 $mail->{contenttype} = "text/html";
1291 $mail->{message} =~ s/\r//g;
1292 $mail->{message} =~ s/\n/<br>\n/g;
1293 $myconfig->{signature} =~ s/\n/<br>\n/g;
1294 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1296 open(IN, $self->{tmpfile})
1297 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1299 $mail->{message} .= $_;
1306 if (!$self->{"do_not_attach"}) {
1307 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1308 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1309 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1310 "name" => $attachment_name }];
1313 $mail->{message} =~ s/\r//g;
1314 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1318 my $err = $mail->send();
1319 $self->error($self->cleanup . "$err") if ($err);
1323 $self->{OUT} = $out;
1325 my $numbytes = (-s $self->{tmpfile});
1326 open(IN, $self->{tmpfile})
1327 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1329 $self->{copies} = 1 unless $self->{media} eq 'printer';
1331 chdir("$self->{cwd}");
1332 #print(STDERR "Kopien $self->{copies}\n");
1333 #print(STDERR "OUT $self->{OUT}\n");
1334 for my $i (1 .. $self->{copies}) {
1336 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1337 print OUT while <IN>;
1342 $self->{attachment_filename} = ($self->{attachment_filename})
1343 ? $self->{attachment_filename}
1344 : $self->generate_attachment_filename();
1346 # launch application
1347 print qq|Content-Type: | . $template->get_mime_type() . qq|
1348 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1349 Content-Length: $numbytes
1353 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1364 chdir("$self->{cwd}");
1365 $main::lxdebug->leave_sub();
1368 sub get_formname_translation {
1369 $main::lxdebug->enter_sub();
1370 my ($self, $formname) = @_;
1372 $formname ||= $self->{formname};
1374 my %formname_translations = (
1375 bin_list => $main::locale->text('Bin List'),
1376 credit_note => $main::locale->text('Credit Note'),
1377 invoice => $main::locale->text('Invoice'),
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 sales_delivery_order => $main::locale->text('Delivery Order'),
1386 purchase_delivery_order => $main::locale->text('Delivery Order'),
1387 dunning => $main::locale->text('Dunning'),
1390 $main::lxdebug->leave_sub();
1391 return $formname_translations{$formname}
1394 sub get_number_prefix_for_type {
1395 $main::lxdebug->enter_sub();
1399 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1400 : ($self->{type} =~ /_quotation$/) ? 'quo'
1401 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1404 $main::lxdebug->leave_sub();
1408 sub get_extension_for_format {
1409 $main::lxdebug->enter_sub();
1412 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1413 : $self->{format} =~ /postscript/i ? ".ps"
1414 : $self->{format} =~ /opendocument/i ? ".odt"
1415 : $self->{format} =~ /excel/i ? ".xls"
1416 : $self->{format} =~ /html/i ? ".html"
1419 $main::lxdebug->leave_sub();
1423 sub generate_attachment_filename {
1424 $main::lxdebug->enter_sub();
1427 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1428 my $prefix = $self->get_number_prefix_for_type();
1430 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1431 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1433 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1434 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1437 $attachment_filename = "";
1440 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1441 $attachment_filename =~ s|[\s/\\]+|_|g;
1443 $main::lxdebug->leave_sub();
1444 return $attachment_filename;
1447 sub generate_email_subject {
1448 $main::lxdebug->enter_sub();
1451 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1452 my $prefix = $self->get_number_prefix_for_type();
1454 if ($subject && $self->{"${prefix}number"}) {
1455 $subject .= " " . $self->{"${prefix}number"}
1458 $main::lxdebug->leave_sub();
1463 $main::lxdebug->enter_sub();
1467 chdir("$self->{tmpdir}");
1470 if (-f "$self->{tmpfile}.err") {
1471 open(FH, "$self->{tmpfile}.err");
1476 if ($self->{tmpfile} && ! $::keep_temp_files) {
1477 $self->{tmpfile} =~ s|.*/||g;
1479 $self->{tmpfile} =~ s/\.\w+$//g;
1480 my $tmpfile = $self->{tmpfile};
1481 unlink(<$tmpfile.*>);
1484 chdir("$self->{cwd}");
1486 $main::lxdebug->leave_sub();
1492 $main::lxdebug->enter_sub();
1494 my ($self, $date, $myconfig) = @_;
1497 if ($date && $date =~ /\D/) {
1499 if ($myconfig->{dateformat} =~ /^yy/) {
1500 ($yy, $mm, $dd) = split /\D/, $date;
1502 if ($myconfig->{dateformat} =~ /^mm/) {
1503 ($mm, $dd, $yy) = split /\D/, $date;
1505 if ($myconfig->{dateformat} =~ /^dd/) {
1506 ($dd, $mm, $yy) = split /\D/, $date;
1511 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1512 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1514 $dd = "0$dd" if ($dd < 10);
1515 $mm = "0$mm" if ($mm < 10);
1517 $date = "$yy$mm$dd";
1520 $main::lxdebug->leave_sub();
1525 # Database routines used throughout
1527 sub _dbconnect_options {
1529 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1536 $main::lxdebug->enter_sub(2);
1538 my ($self, $myconfig) = @_;
1540 # connect to database
1541 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1545 if ($myconfig->{dboptions}) {
1546 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1549 $main::lxdebug->leave_sub(2);
1554 sub dbconnect_noauto {
1555 $main::lxdebug->enter_sub();
1557 my ($self, $myconfig) = @_;
1559 # connect to database
1560 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1564 if ($myconfig->{dboptions}) {
1565 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1568 $main::lxdebug->leave_sub();
1573 sub get_standard_dbh {
1574 $main::lxdebug->enter_sub(2);
1577 my $myconfig = shift || \%::myconfig;
1579 if ($standard_dbh && !$standard_dbh->{Active}) {
1580 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1581 undef $standard_dbh;
1584 $standard_dbh ||= SL::DB::create->dbh;
1586 $main::lxdebug->leave_sub(2);
1588 return $standard_dbh;
1592 $main::lxdebug->enter_sub();
1594 my ($self, $date, $myconfig) = @_;
1595 my $dbh = $self->dbconnect($myconfig);
1597 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1598 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1599 my ($closed) = $sth->fetchrow_array;
1601 $main::lxdebug->leave_sub();
1606 sub update_balance {
1607 $main::lxdebug->enter_sub();
1609 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1611 # if we have a value, go do it
1614 # retrieve balance from table
1615 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1616 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1617 my ($balance) = $sth->fetchrow_array;
1623 $query = "UPDATE $table SET $field = $balance WHERE $where";
1624 do_query($self, $dbh, $query, @values);
1626 $main::lxdebug->leave_sub();
1629 sub update_exchangerate {
1630 $main::lxdebug->enter_sub();
1632 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1634 # some sanity check for currency
1636 $main::lxdebug->leave_sub();
1639 $query = qq|SELECT curr FROM defaults|;
1641 my ($currency) = selectrow_query($self, $dbh, $query);
1642 my ($defaultcurrency) = split m/:/, $currency;
1645 if ($curr eq $defaultcurrency) {
1646 $main::lxdebug->leave_sub();
1650 $query = qq|SELECT e.curr FROM exchangerate e
1651 WHERE e.curr = ? AND e.transdate = ?
1653 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1662 $buy = conv_i($buy, "NULL");
1663 $sell = conv_i($sell, "NULL");
1666 if ($buy != 0 && $sell != 0) {
1667 $set = "buy = $buy, sell = $sell";
1668 } elsif ($buy != 0) {
1669 $set = "buy = $buy";
1670 } elsif ($sell != 0) {
1671 $set = "sell = $sell";
1674 if ($sth->fetchrow_array) {
1675 $query = qq|UPDATE exchangerate
1681 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1682 VALUES (?, $buy, $sell, ?)|;
1685 do_query($self, $dbh, $query, $curr, $transdate);
1687 $main::lxdebug->leave_sub();
1690 sub save_exchangerate {
1691 $main::lxdebug->enter_sub();
1693 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1695 my $dbh = $self->dbconnect($myconfig);
1699 $buy = $rate if $fld eq 'buy';
1700 $sell = $rate if $fld eq 'sell';
1703 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1708 $main::lxdebug->leave_sub();
1711 sub get_exchangerate {
1712 $main::lxdebug->enter_sub();
1714 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1717 unless ($transdate) {
1718 $main::lxdebug->leave_sub();
1722 $query = qq|SELECT curr FROM defaults|;
1724 my ($currency) = selectrow_query($self, $dbh, $query);
1725 my ($defaultcurrency) = split m/:/, $currency;
1727 if ($currency eq $defaultcurrency) {
1728 $main::lxdebug->leave_sub();
1732 $query = qq|SELECT e.$fld FROM exchangerate e
1733 WHERE e.curr = ? AND e.transdate = ?|;
1734 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1738 $main::lxdebug->leave_sub();
1740 return $exchangerate;
1743 sub check_exchangerate {
1744 $main::lxdebug->enter_sub();
1746 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1748 if ($fld !~/^buy|sell$/) {
1749 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1752 unless ($transdate) {
1753 $main::lxdebug->leave_sub();
1757 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1759 if ($currency eq $defaultcurrency) {
1760 $main::lxdebug->leave_sub();
1764 my $dbh = $self->get_standard_dbh($myconfig);
1765 my $query = qq|SELECT e.$fld FROM exchangerate e
1766 WHERE e.curr = ? AND e.transdate = ?|;
1768 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1770 $main::lxdebug->leave_sub();
1772 return $exchangerate;
1775 sub get_all_currencies {
1776 $main::lxdebug->enter_sub();
1779 my $myconfig = shift || \%::myconfig;
1780 my $dbh = $self->get_standard_dbh($myconfig);
1782 my $query = qq|SELECT curr FROM defaults|;
1784 my ($curr) = selectrow_query($self, $dbh, $query);
1785 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1787 $main::lxdebug->leave_sub();
1792 sub get_default_currency {
1793 $main::lxdebug->enter_sub();
1795 my ($self, $myconfig) = @_;
1796 my @currencies = $self->get_all_currencies($myconfig);
1798 $main::lxdebug->leave_sub();
1800 return $currencies[0];
1803 sub set_payment_options {
1804 $main::lxdebug->enter_sub();
1806 my ($self, $myconfig, $transdate) = @_;
1808 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1810 my $dbh = $self->get_standard_dbh($myconfig);
1813 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1814 qq|FROM payment_terms p | .
1817 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1818 $self->{payment_terms}) =
1819 selectrow_query($self, $dbh, $query, $self->{payment_id});
1821 if ($transdate eq "") {
1822 if ($self->{invdate}) {
1823 $transdate = $self->{invdate};
1825 $transdate = $self->{transdate};
1830 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1831 qq|FROM payment_terms|;
1832 ($self->{netto_date}, $self->{skonto_date}) =
1833 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1835 my ($invtotal, $total);
1836 my (%amounts, %formatted_amounts);
1838 if ($self->{type} =~ /_order$/) {
1839 $amounts{invtotal} = $self->{ordtotal};
1840 $amounts{total} = $self->{ordtotal};
1842 } elsif ($self->{type} =~ /_quotation$/) {
1843 $amounts{invtotal} = $self->{quototal};
1844 $amounts{total} = $self->{quototal};
1847 $amounts{invtotal} = $self->{invtotal};
1848 $amounts{total} = $self->{total};
1850 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1852 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1854 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1855 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1856 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1858 foreach (keys %amounts) {
1859 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1860 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1863 if ($self->{"language_id"}) {
1865 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1866 qq|FROM translation_payment_terms t | .
1867 qq|LEFT JOIN language l ON t.language_id = l.id | .
1868 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1869 my ($description_long, $output_numberformat, $output_dateformat,
1870 $output_longdates) =
1871 selectrow_query($self, $dbh, $query,
1872 $self->{"language_id"}, $self->{"payment_id"});
1874 $self->{payment_terms} = $description_long if ($description_long);
1876 if ($output_dateformat) {
1877 foreach my $key (qw(netto_date skonto_date)) {
1879 $main::locale->reformat_date($myconfig, $self->{$key},
1885 if ($output_numberformat &&
1886 ($output_numberformat ne $myconfig->{"numberformat"})) {
1887 my $saved_numberformat = $myconfig->{"numberformat"};
1888 $myconfig->{"numberformat"} = $output_numberformat;
1889 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1890 $myconfig->{"numberformat"} = $saved_numberformat;
1894 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1895 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1896 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1897 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1898 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1899 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1900 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1902 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1904 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1906 $main::lxdebug->leave_sub();
1910 sub get_template_language {
1911 $main::lxdebug->enter_sub();
1913 my ($self, $myconfig) = @_;
1915 my $template_code = "";
1917 if ($self->{language_id}) {
1918 my $dbh = $self->get_standard_dbh($myconfig);
1919 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1920 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1923 $main::lxdebug->leave_sub();
1925 return $template_code;
1928 sub get_printer_code {
1929 $main::lxdebug->enter_sub();
1931 my ($self, $myconfig) = @_;
1933 my $template_code = "";
1935 if ($self->{printer_id}) {
1936 my $dbh = $self->get_standard_dbh($myconfig);
1937 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1938 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1941 $main::lxdebug->leave_sub();
1943 return $template_code;
1947 $main::lxdebug->enter_sub();
1949 my ($self, $myconfig) = @_;
1951 my $template_code = "";
1953 if ($self->{shipto_id}) {
1954 my $dbh = $self->get_standard_dbh($myconfig);
1955 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1956 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1957 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1960 $main::lxdebug->leave_sub();
1964 $main::lxdebug->enter_sub();
1966 my ($self, $dbh, $id, $module) = @_;
1971 foreach my $item (qw(name department_1 department_2 street zipcode city country
1972 contact cp_gender phone fax email)) {
1973 if ($self->{"shipto$item"}) {
1974 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1976 push(@values, $self->{"shipto${item}"});
1980 if ($self->{shipto_id}) {
1981 my $query = qq|UPDATE shipto set
1983 shiptodepartment_1 = ?,
1984 shiptodepartment_2 = ?,
1990 shiptocp_gender = ?,
1994 WHERE shipto_id = ?|;
1995 do_query($self, $dbh, $query, @values, $self->{shipto_id});
1997 my $query = qq|SELECT * FROM shipto
1998 WHERE shiptoname = ? AND
1999 shiptodepartment_1 = ? AND
2000 shiptodepartment_2 = ? AND
2001 shiptostreet = ? AND
2002 shiptozipcode = ? AND
2004 shiptocountry = ? AND
2005 shiptocontact = ? AND
2006 shiptocp_gender = ? AND
2012 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2015 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2016 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2017 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2018 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2019 do_query($self, $dbh, $query, $id, @values, $module);
2024 $main::lxdebug->leave_sub();
2028 $main::lxdebug->enter_sub();
2030 my ($self, $dbh) = @_;
2032 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2034 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2035 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2036 $self->{"employee_id"} *= 1;
2038 $main::lxdebug->leave_sub();
2041 sub get_employee_data {
2042 $main::lxdebug->enter_sub();
2047 Common::check_params(\%params, qw(prefix));
2048 Common::check_params_x(\%params, qw(id));
2051 $main::lxdebug->leave_sub();
2055 my $myconfig = \%main::myconfig;
2056 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2058 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2061 my $user = User->new($login);
2062 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2064 $self->{$params{prefix} . '_login'} = $login;
2065 $self->{$params{prefix} . '_name'} ||= $login;
2068 $main::lxdebug->leave_sub();
2072 $main::lxdebug->enter_sub();
2074 my ($self, $myconfig, $reference_date) = @_;
2076 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2078 my $dbh = $self->get_standard_dbh($myconfig);
2079 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2080 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2082 $main::lxdebug->leave_sub();
2088 $main::lxdebug->enter_sub();
2090 my ($self, $dbh, $id, $key) = @_;
2092 $key = "all_contacts" unless ($key);
2096 $main::lxdebug->leave_sub();
2101 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2102 qq|FROM contacts | .
2103 qq|WHERE cp_cv_id = ? | .
2104 qq|ORDER BY lower(cp_name)|;
2106 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2108 $main::lxdebug->leave_sub();
2112 $main::lxdebug->enter_sub();
2114 my ($self, $dbh, $key) = @_;
2116 my ($all, $old_id, $where, @values);
2118 if (ref($key) eq "HASH") {
2121 $key = "ALL_PROJECTS";
2123 foreach my $p (keys(%{$params})) {
2125 $all = $params->{$p};
2126 } elsif ($p eq "old_id") {
2127 $old_id = $params->{$p};
2128 } elsif ($p eq "key") {
2129 $key = $params->{$p};
2135 $where = "WHERE active ";
2137 if (ref($old_id) eq "ARRAY") {
2138 my @ids = grep({ $_ } @{$old_id});
2140 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2141 push(@values, @ids);
2144 $where .= " OR (id = ?) ";
2145 push(@values, $old_id);
2151 qq|SELECT id, projectnumber, description, active | .
2154 qq|ORDER BY lower(projectnumber)|;
2156 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2158 $main::lxdebug->leave_sub();
2162 $main::lxdebug->enter_sub();
2164 my ($self, $dbh, $vc_id, $key) = @_;
2166 $key = "all_shipto" unless ($key);
2169 # get shipping addresses
2170 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2172 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2178 $main::lxdebug->leave_sub();
2182 $main::lxdebug->enter_sub();
2184 my ($self, $dbh, $key) = @_;
2186 $key = "all_printers" unless ($key);
2188 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2190 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2192 $main::lxdebug->leave_sub();
2196 $main::lxdebug->enter_sub();
2198 my ($self, $dbh, $params) = @_;
2201 $key = $params->{key};
2202 $key = "all_charts" unless ($key);
2204 my $transdate = quote_db_date($params->{transdate});
2207 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2209 qq|LEFT JOIN taxkeys tk ON | .
2210 qq|(tk.id = (SELECT id FROM taxkeys | .
2211 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2212 qq| ORDER BY startdate DESC LIMIT 1)) | .
2213 qq|ORDER BY c.accno|;
2215 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2217 $main::lxdebug->leave_sub();
2220 sub _get_taxcharts {
2221 $main::lxdebug->enter_sub();
2223 my ($self, $dbh, $params) = @_;
2225 my $key = "all_taxcharts";
2228 if (ref $params eq 'HASH') {
2229 $key = $params->{key} if ($params->{key});
2230 if ($params->{module} eq 'AR') {
2231 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2233 } elsif ($params->{module} eq 'AP') {
2234 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2241 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2243 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2245 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2247 $main::lxdebug->leave_sub();
2251 $main::lxdebug->enter_sub();
2253 my ($self, $dbh, $key) = @_;
2255 $key = "all_taxzones" unless ($key);
2257 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2259 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2261 $main::lxdebug->leave_sub();
2264 sub _get_employees {
2265 $main::lxdebug->enter_sub();
2267 my ($self, $dbh, $default_key, $key) = @_;
2269 $key = $default_key unless ($key);
2270 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2272 $main::lxdebug->leave_sub();
2275 sub _get_business_types {
2276 $main::lxdebug->enter_sub();
2278 my ($self, $dbh, $key) = @_;
2280 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2281 $options->{key} ||= "all_business_types";
2284 if (exists $options->{salesman}) {
2285 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2288 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2290 $main::lxdebug->leave_sub();
2293 sub _get_languages {
2294 $main::lxdebug->enter_sub();
2296 my ($self, $dbh, $key) = @_;
2298 $key = "all_languages" unless ($key);
2300 my $query = qq|SELECT * FROM language ORDER BY id|;
2302 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2304 $main::lxdebug->leave_sub();
2307 sub _get_dunning_configs {
2308 $main::lxdebug->enter_sub();
2310 my ($self, $dbh, $key) = @_;
2312 $key = "all_dunning_configs" unless ($key);
2314 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2316 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2318 $main::lxdebug->leave_sub();
2321 sub _get_currencies {
2322 $main::lxdebug->enter_sub();
2324 my ($self, $dbh, $key) = @_;
2326 $key = "all_currencies" unless ($key);
2328 my $query = qq|SELECT curr AS currency FROM defaults|;
2330 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2332 $main::lxdebug->leave_sub();
2336 $main::lxdebug->enter_sub();
2338 my ($self, $dbh, $key) = @_;
2340 $key = "all_payments" unless ($key);
2342 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2344 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2346 $main::lxdebug->leave_sub();
2349 sub _get_customers {
2350 $main::lxdebug->enter_sub();
2352 my ($self, $dbh, $key) = @_;
2354 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2355 $options->{key} ||= "all_customers";
2356 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2359 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2360 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2361 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2363 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2364 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2366 $main::lxdebug->leave_sub();
2370 $main::lxdebug->enter_sub();
2372 my ($self, $dbh, $key) = @_;
2374 $key = "all_vendors" unless ($key);
2376 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2378 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2380 $main::lxdebug->leave_sub();
2383 sub _get_departments {
2384 $main::lxdebug->enter_sub();
2386 my ($self, $dbh, $key) = @_;
2388 $key = "all_departments" unless ($key);
2390 my $query = qq|SELECT * FROM department ORDER BY description|;
2392 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2394 $main::lxdebug->leave_sub();
2397 sub _get_warehouses {
2398 $main::lxdebug->enter_sub();
2400 my ($self, $dbh, $param) = @_;
2402 my ($key, $bins_key);
2404 if ('' eq ref $param) {
2408 $key = $param->{key};
2409 $bins_key = $param->{bins};
2412 my $query = qq|SELECT w.* FROM warehouse w
2413 WHERE (NOT w.invalid) AND
2414 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2415 ORDER BY w.sortkey|;
2417 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2420 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2421 my $sth = prepare_query($self, $dbh, $query);
2423 foreach my $warehouse (@{ $self->{$key} }) {
2424 do_statement($self, $sth, $query, $warehouse->{id});
2425 $warehouse->{$bins_key} = [];
2427 while (my $ref = $sth->fetchrow_hashref()) {
2428 push @{ $warehouse->{$bins_key} }, $ref;
2434 $main::lxdebug->leave_sub();
2438 $main::lxdebug->enter_sub();
2440 my ($self, $dbh, $table, $key, $sortkey) = @_;
2442 my $query = qq|SELECT * FROM $table|;
2443 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2445 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2447 $main::lxdebug->leave_sub();
2451 # $main::lxdebug->enter_sub();
2453 # my ($self, $dbh, $key) = @_;
2455 # $key ||= "all_groups";
2457 # my $groups = $main::auth->read_groups();
2459 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2461 # $main::lxdebug->leave_sub();
2465 $main::lxdebug->enter_sub();
2470 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2471 my ($sth, $query, $ref);
2473 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2474 my $vc_id = $self->{"${vc}_id"};
2476 if ($params{"contacts"}) {
2477 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2480 if ($params{"shipto"}) {
2481 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2484 if ($params{"projects"} || $params{"all_projects"}) {
2485 $self->_get_projects($dbh, $params{"all_projects"} ?
2486 $params{"all_projects"} : $params{"projects"},
2487 $params{"all_projects"} ? 1 : 0);
2490 if ($params{"printers"}) {
2491 $self->_get_printers($dbh, $params{"printers"});
2494 if ($params{"languages"}) {
2495 $self->_get_languages($dbh, $params{"languages"});
2498 if ($params{"charts"}) {
2499 $self->_get_charts($dbh, $params{"charts"});
2502 if ($params{"taxcharts"}) {
2503 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2506 if ($params{"taxzones"}) {
2507 $self->_get_taxzones($dbh, $params{"taxzones"});
2510 if ($params{"employees"}) {
2511 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2514 if ($params{"salesmen"}) {
2515 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2518 if ($params{"business_types"}) {
2519 $self->_get_business_types($dbh, $params{"business_types"});
2522 if ($params{"dunning_configs"}) {
2523 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2526 if($params{"currencies"}) {
2527 $self->_get_currencies($dbh, $params{"currencies"});
2530 if($params{"customers"}) {
2531 $self->_get_customers($dbh, $params{"customers"});
2534 if($params{"vendors"}) {
2535 if (ref $params{"vendors"} eq 'HASH') {
2536 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2538 $self->_get_vendors($dbh, $params{"vendors"});
2542 if($params{"payments"}) {
2543 $self->_get_payments($dbh, $params{"payments"});
2546 if($params{"departments"}) {
2547 $self->_get_departments($dbh, $params{"departments"});
2550 if ($params{price_factors}) {
2551 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2554 if ($params{warehouses}) {
2555 $self->_get_warehouses($dbh, $params{warehouses});
2558 # if ($params{groups}) {
2559 # $self->_get_groups($dbh, $params{groups});
2562 if ($params{partsgroup}) {
2563 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2566 $main::lxdebug->leave_sub();
2569 # this sub gets the id and name from $table
2571 $main::lxdebug->enter_sub();
2573 my ($self, $myconfig, $table) = @_;
2575 # connect to database
2576 my $dbh = $self->get_standard_dbh($myconfig);
2578 $table = $table eq "customer" ? "customer" : "vendor";
2579 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2581 my ($query, @values);
2583 if (!$self->{openinvoices}) {
2585 if ($self->{customernumber} ne "") {
2586 $where = qq|(vc.customernumber ILIKE ?)|;
2587 push(@values, '%' . $self->{customernumber} . '%');
2589 $where = qq|(vc.name ILIKE ?)|;
2590 push(@values, '%' . $self->{$table} . '%');
2594 qq~SELECT vc.id, vc.name,
2595 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2597 WHERE $where AND (NOT vc.obsolete)
2601 qq~SELECT DISTINCT vc.id, vc.name,
2602 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2604 JOIN $table vc ON (a.${table}_id = vc.id)
2605 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2607 push(@values, '%' . $self->{$table} . '%');
2610 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2612 $main::lxdebug->leave_sub();
2614 return scalar(@{ $self->{name_list} });
2617 # the selection sub is used in the AR, AP, IS, IR and OE module
2620 $main::lxdebug->enter_sub();
2622 my ($self, $myconfig, $table, $module) = @_;
2625 my $dbh = $self->get_standard_dbh;
2627 $table = $table eq "customer" ? "customer" : "vendor";
2629 my $query = qq|SELECT count(*) FROM $table|;
2630 my ($count) = selectrow_query($self, $dbh, $query);
2632 # build selection list
2633 if ($count <= $myconfig->{vclimit}) {
2634 $query = qq|SELECT id, name, salesman_id
2635 FROM $table WHERE NOT obsolete
2637 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2641 $self->get_employee($dbh);
2643 # setup sales contacts
2644 $query = qq|SELECT e.id, e.name
2646 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2647 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2650 push(@{ $self->{all_employees} },
2651 { id => $self->{employee_id},
2652 name => $self->{employee} });
2654 # sort the whole thing
2655 @{ $self->{all_employees} } =
2656 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2658 if ($module eq 'AR') {
2660 # prepare query for departments
2661 $query = qq|SELECT id, description
2664 ORDER BY description|;
2667 $query = qq|SELECT id, description
2669 ORDER BY description|;
2672 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2675 $query = qq|SELECT id, description
2679 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2682 $query = qq|SELECT printer_description, id
2684 ORDER BY printer_description|;
2686 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2689 $query = qq|SELECT id, description
2693 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2695 $main::lxdebug->leave_sub();
2698 sub language_payment {
2699 $main::lxdebug->enter_sub();
2701 my ($self, $myconfig) = @_;
2703 my $dbh = $self->get_standard_dbh($myconfig);
2705 my $query = qq|SELECT id, description
2709 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2712 $query = qq|SELECT printer_description, id
2714 ORDER BY printer_description|;
2716 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2719 $query = qq|SELECT id, description
2723 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2725 # get buchungsgruppen
2726 $query = qq|SELECT id, description
2727 FROM buchungsgruppen|;
2729 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2731 $main::lxdebug->leave_sub();
2734 # this is only used for reports
2735 sub all_departments {
2736 $main::lxdebug->enter_sub();
2738 my ($self, $myconfig, $table) = @_;
2740 my $dbh = $self->get_standard_dbh($myconfig);
2743 if ($table eq 'customer') {
2744 $where = "WHERE role = 'P' ";
2747 my $query = qq|SELECT id, description
2750 ORDER BY description|;
2751 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2753 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2755 $main::lxdebug->leave_sub();
2759 $main::lxdebug->enter_sub();
2761 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2764 if ($table eq "customer") {
2773 $self->all_vc($myconfig, $table, $module);
2775 # get last customers or vendors
2776 my ($query, $sth, $ref);
2778 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2783 my $transdate = "current_date";
2784 if ($self->{transdate}) {
2785 $transdate = $dbh->quote($self->{transdate});
2788 # now get the account numbers
2789 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2790 FROM chart c, taxkeys tk
2791 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2792 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2795 $sth = $dbh->prepare($query);
2797 do_statement($self, $sth, $query, '%' . $module . '%');
2799 $self->{accounts} = "";
2800 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2802 foreach my $key (split(/:/, $ref->{link})) {
2803 if ($key =~ /\Q$module\E/) {
2805 # cross reference for keys
2806 $xkeyref{ $ref->{accno} } = $key;
2808 push @{ $self->{"${module}_links"}{$key} },
2809 { accno => $ref->{accno},
2810 description => $ref->{description},
2811 taxkey => $ref->{taxkey_id},
2812 tax_id => $ref->{tax_id} };
2814 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2820 # get taxkeys and description
2821 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2822 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2824 if (($module eq "AP") || ($module eq "AR")) {
2825 # get tax rates and description
2826 $query = qq|SELECT * FROM tax|;
2827 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2833 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2834 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2835 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2836 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2838 d.description AS department,
2841 JOIN $table c ON (a.${table}_id = c.id)
2842 LEFT JOIN employee e ON (e.id = a.employee_id)
2843 LEFT JOIN department d ON (d.id = a.department_id)
2845 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2847 foreach my $key (keys %$ref) {
2848 $self->{$key} = $ref->{$key};
2851 my $transdate = "current_date";
2852 if ($self->{transdate}) {
2853 $transdate = $dbh->quote($self->{transdate});
2856 # now get the account numbers
2857 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2859 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2861 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2862 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2865 $sth = $dbh->prepare($query);
2866 do_statement($self, $sth, $query, "%$module%");
2868 $self->{accounts} = "";
2869 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2871 foreach my $key (split(/:/, $ref->{link})) {
2872 if ($key =~ /\Q$module\E/) {
2874 # cross reference for keys
2875 $xkeyref{ $ref->{accno} } = $key;
2877 push @{ $self->{"${module}_links"}{$key} },
2878 { accno => $ref->{accno},
2879 description => $ref->{description},
2880 taxkey => $ref->{taxkey_id},
2881 tax_id => $ref->{tax_id} };
2883 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2889 # get amounts from individual entries
2892 c.accno, c.description,
2893 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2897 LEFT JOIN chart c ON (c.id = a.chart_id)
2898 LEFT JOIN project p ON (p.id = a.project_id)
2899 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2900 WHERE (tk.taxkey_id=a.taxkey) AND
2901 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2902 THEN tk.chart_id = a.chart_id
2905 OR (c.link='%tax%')) AND
2906 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2907 WHERE a.trans_id = ?
2908 AND a.fx_transaction = '0'
2909 ORDER BY a.acc_trans_id, a.transdate|;
2910 $sth = $dbh->prepare($query);
2911 do_statement($self, $sth, $query, $self->{id});
2913 # get exchangerate for currency
2914 $self->{exchangerate} =
2915 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2918 # store amounts in {acc_trans}{$key} for multiple accounts
2919 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2920 $ref->{exchangerate} =
2921 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2922 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2925 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2926 $ref->{amount} *= -1;
2928 $ref->{index} = $index;
2930 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2936 d.curr AS currencies, d.closedto, d.revtrans,
2937 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2938 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2940 $ref = selectfirst_hashref_query($self, $dbh, $query);
2941 map { $self->{$_} = $ref->{$_} } keys %$ref;
2948 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2949 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2950 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2952 $ref = selectfirst_hashref_query($self, $dbh, $query);
2953 map { $self->{$_} = $ref->{$_} } keys %$ref;
2955 if ($self->{"$self->{vc}_id"}) {
2957 # only setup currency
2958 ($self->{currency}) = split(/:/, $self->{currencies});
2962 $self->lastname_used($dbh, $myconfig, $table, $module);
2964 # get exchangerate for currency
2965 $self->{exchangerate} =
2966 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2972 $main::lxdebug->leave_sub();
2976 $main::lxdebug->enter_sub();
2978 my ($self, $dbh, $myconfig, $table, $module) = @_;
2982 $table = $table eq "customer" ? "customer" : "vendor";
2983 my %column_map = ("a.curr" => "currency",
2984 "a.${table}_id" => "${table}_id",
2985 "a.department_id" => "department_id",
2986 "d.description" => "department",
2987 "ct.name" => $table,
2988 "current_date + ct.terms" => "duedate",
2991 if ($self->{type} =~ /delivery_order/) {
2992 $arap = 'delivery_orders';
2993 delete $column_map{"a.curr"};
2995 } elsif ($self->{type} =~ /_order/) {
2997 $where = "quotation = '0'";
2999 } elsif ($self->{type} =~ /_quotation/) {
3001 $where = "quotation = '1'";
3003 } elsif ($table eq 'customer') {
3011 $where = "($where) AND" if ($where);
3012 my $query = qq|SELECT MAX(id) FROM $arap
3013 WHERE $where ${table}_id > 0|;
3014 my ($trans_id) = selectrow_query($self, $dbh, $query);
3017 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3018 $query = qq|SELECT $column_spec
3020 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3021 LEFT JOIN department d ON (a.department_id = d.id)
3023 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3025 map { $self->{$_} = $ref->{$_} } values %column_map;
3027 $main::lxdebug->leave_sub();
3031 $main::lxdebug->enter_sub();
3034 my $myconfig = shift || \%::myconfig;
3035 my ($thisdate, $days) = @_;
3037 my $dbh = $self->get_standard_dbh($myconfig);
3042 my $dateformat = $myconfig->{dateformat};
3043 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3044 $thisdate = $dbh->quote($thisdate);
3045 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3047 $query = qq|SELECT current_date AS thisdate|;
3050 ($thisdate) = selectrow_query($self, $dbh, $query);
3052 $main::lxdebug->leave_sub();
3058 $main::lxdebug->enter_sub();
3060 my ($self, $string) = @_;
3062 if ($string !~ /%/) {
3063 $string = "%$string%";
3066 $string =~ s/\'/\'\'/g;
3068 $main::lxdebug->leave_sub();
3074 $main::lxdebug->enter_sub();
3076 my ($self, $flds, $new, $count, $numrows) = @_;
3080 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3085 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3087 my $j = $item->{ndx} - 1;
3088 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3092 for $i ($count + 1 .. $numrows) {
3093 map { delete $self->{"${_}_$i"} } @{$flds};
3096 $main::lxdebug->leave_sub();
3100 $main::lxdebug->enter_sub();
3102 my ($self, $myconfig) = @_;
3106 my $dbh = $self->dbconnect_noauto($myconfig);
3108 my $query = qq|DELETE FROM status
3109 WHERE (formname = ?) AND (trans_id = ?)|;
3110 my $sth = prepare_query($self, $dbh, $query);
3112 if ($self->{formname} =~ /(check|receipt)/) {
3113 for $i (1 .. $self->{rowcount}) {
3114 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3117 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3121 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3122 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3124 my %queued = split / /, $self->{queued};
3127 if ($self->{formname} =~ /(check|receipt)/) {
3129 # this is a check or receipt, add one entry for each lineitem
3130 my ($accno) = split /--/, $self->{account};
3131 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3132 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3133 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3134 $sth = prepare_query($self, $dbh, $query);
3136 for $i (1 .. $self->{rowcount}) {
3137 if ($self->{"checked_$i"}) {
3138 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3144 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3145 VALUES (?, ?, ?, ?, ?)|;
3146 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3147 $queued{$self->{formname}}, $self->{formname});
3153 $main::lxdebug->leave_sub();
3157 $main::lxdebug->enter_sub();
3159 my ($self, $dbh) = @_;
3161 my ($query, $printed, $emailed);
3163 my $formnames = $self->{printed};
3164 my $emailforms = $self->{emailed};
3166 $query = qq|DELETE FROM status
3167 WHERE (formname = ?) AND (trans_id = ?)|;
3168 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3170 # this only applies to the forms
3171 # checks and receipts are posted when printed or queued
3173 if ($self->{queued}) {
3174 my %queued = split / /, $self->{queued};
3176 foreach my $formname (keys %queued) {
3177 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3178 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3180 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3181 VALUES (?, ?, ?, ?, ?)|;
3182 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3184 $formnames =~ s/\Q$self->{formname}\E//;
3185 $emailforms =~ s/\Q$self->{formname}\E//;
3190 # save printed, emailed info
3191 $formnames =~ s/^ +//g;
3192 $emailforms =~ s/^ +//g;
3195 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3196 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3198 foreach my $formname (keys %status) {
3199 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3200 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3202 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3203 VALUES (?, ?, ?, ?)|;
3204 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3207 $main::lxdebug->leave_sub();
3211 # $main::locale->text('SAVED')
3212 # $main::locale->text('DELETED')
3213 # $main::locale->text('ADDED')
3214 # $main::locale->text('PAYMENT POSTED')
3215 # $main::locale->text('POSTED')
3216 # $main::locale->text('POSTED AS NEW')
3217 # $main::locale->text('ELSE')
3218 # $main::locale->text('SAVED FOR DUNNING')
3219 # $main::locale->text('DUNNING STARTED')
3220 # $main::locale->text('PRINTED')
3221 # $main::locale->text('MAILED')
3222 # $main::locale->text('SCREENED')
3223 # $main::locale->text('CANCELED')
3224 # $main::locale->text('invoice')
3225 # $main::locale->text('proforma')
3226 # $main::locale->text('sales_order')
3227 # $main::locale->text('pick_list')
3228 # $main::locale->text('purchase_order')
3229 # $main::locale->text('bin_list')
3230 # $main::locale->text('sales_quotation')
3231 # $main::locale->text('request_quotation')
3234 $main::lxdebug->enter_sub();
3237 my $dbh = shift || $self->get_standard_dbh;
3239 if(!exists $self->{employee_id}) {
3240 &get_employee($self, $dbh);
3244 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3245 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3246 my @values = (conv_i($self->{id}), $self->{login},
3247 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3248 do_query($self, $dbh, $query, @values);
3252 $main::lxdebug->leave_sub();
3256 $main::lxdebug->enter_sub();
3258 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3259 my ($orderBy, $desc) = split(/\-\-/, $order);
3260 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3263 if ($trans_id ne "") {
3265 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 | .
3266 qq|FROM history_erp h | .
3267 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3268 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3271 my $sth = $dbh->prepare($query) || $self->dberror($query);
3273 $sth->execute() || $self->dberror("$query");
3275 while(my $hash_ref = $sth->fetchrow_hashref()) {
3276 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3277 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3278 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3279 $tempArray[$i++] = $hash_ref;
3281 $main::lxdebug->leave_sub() and return \@tempArray
3282 if ($i > 0 && $tempArray[0] ne "");
3284 $main::lxdebug->leave_sub();
3288 sub update_defaults {
3289 $main::lxdebug->enter_sub();
3291 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3294 if ($provided_dbh) {
3295 $dbh = $provided_dbh;
3297 $dbh = $self->dbconnect_noauto($myconfig);
3299 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3300 my $sth = $dbh->prepare($query);
3302 $sth->execute || $self->dberror($query);
3303 my ($var) = $sth->fetchrow_array;
3306 if ($var =~ m/\d+$/) {
3307 my $new_var = (substr $var, $-[0]) * 1 + 1;
3308 my $len_diff = length($var) - $-[0] - length($new_var);
3309 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3315 $query = qq|UPDATE defaults SET $fld = ?|;
3316 do_query($self, $dbh, $query, $var);
3318 if (!$provided_dbh) {
3323 $main::lxdebug->leave_sub();
3328 sub update_business {
3329 $main::lxdebug->enter_sub();
3331 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3334 if ($provided_dbh) {
3335 $dbh = $provided_dbh;
3337 $dbh = $self->dbconnect_noauto($myconfig);
3340 qq|SELECT customernumberinit FROM business
3341 WHERE id = ? FOR UPDATE|;
3342 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3344 return undef unless $var;
3346 if ($var =~ m/\d+$/) {
3347 my $new_var = (substr $var, $-[0]) * 1 + 1;
3348 my $len_diff = length($var) - $-[0] - length($new_var);
3349 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3355 $query = qq|UPDATE business
3356 SET customernumberinit = ?
3358 do_query($self, $dbh, $query, $var, $business_id);
3360 if (!$provided_dbh) {
3365 $main::lxdebug->leave_sub();
3370 sub get_partsgroup {
3371 $main::lxdebug->enter_sub();
3373 my ($self, $myconfig, $p) = @_;
3374 my $target = $p->{target} || 'all_partsgroup';
3376 my $dbh = $self->get_standard_dbh($myconfig);
3378 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3380 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3383 if ($p->{searchitems} eq 'part') {
3384 $query .= qq|WHERE p.inventory_accno_id > 0|;
3386 if ($p->{searchitems} eq 'service') {
3387 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3389 if ($p->{searchitems} eq 'assembly') {
3390 $query .= qq|WHERE p.assembly = '1'|;
3392 if ($p->{searchitems} eq 'labor') {
3393 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3396 $query .= qq|ORDER BY partsgroup|;
3399 $query = qq|SELECT id, partsgroup FROM partsgroup
3400 ORDER BY partsgroup|;
3403 if ($p->{language_code}) {
3404 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3405 t.description AS translation
3407 JOIN parts p ON (p.partsgroup_id = pg.id)
3408 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3409 ORDER BY translation|;
3410 @values = ($p->{language_code});
3413 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3415 $main::lxdebug->leave_sub();
3418 sub get_pricegroup {
3419 $main::lxdebug->enter_sub();
3421 my ($self, $myconfig, $p) = @_;
3423 my $dbh = $self->get_standard_dbh($myconfig);
3425 my $query = qq|SELECT p.id, p.pricegroup
3428 $query .= qq| ORDER BY pricegroup|;
3431 $query = qq|SELECT id, pricegroup FROM pricegroup
3432 ORDER BY pricegroup|;
3435 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3437 $main::lxdebug->leave_sub();
3441 # usage $form->all_years($myconfig, [$dbh])
3442 # return list of all years where bookings found
3445 $main::lxdebug->enter_sub();
3447 my ($self, $myconfig, $dbh) = @_;
3449 $dbh ||= $self->get_standard_dbh($myconfig);
3452 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3453 (SELECT MAX(transdate) FROM acc_trans)|;
3454 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3456 if ($myconfig->{dateformat} =~ /^yy/) {
3457 ($startdate) = split /\W/, $startdate;
3458 ($enddate) = split /\W/, $enddate;
3460 (@_) = split /\W/, $startdate;
3462 (@_) = split /\W/, $enddate;
3467 $startdate = substr($startdate,0,4);
3468 $enddate = substr($enddate,0,4);
3470 while ($enddate >= $startdate) {
3471 push @all_years, $enddate--;
3476 $main::lxdebug->leave_sub();
3480 $main::lxdebug->enter_sub();
3484 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3486 $main::lxdebug->leave_sub();
3490 $main::lxdebug->enter_sub();
3495 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3497 $main::lxdebug->leave_sub();
3506 SL::Form.pm - main data object.
3510 This is the main data object of Lx-Office.
3511 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3512 Points of interest for a beginner are:
3514 - $form->error - renders a generic error in html. accepts an error message
3515 - $form->get_standard_dbh - returns a database connection for the
3517 =head1 SPECIAL FUNCTIONS
3519 =head2 C<_store_value()>
3521 parses a complex var name, and stores it in the form.
3524 $form->_store_value($key, $value);
3526 keys must start with a string, and can contain various tokens.
3527 supported key structures are:
3530 simple key strings work as expected
3535 separating two keys by a dot (.) will result in a hash lookup for the inner value
3536 this is similar to the behaviour of java and templating mechanisms.
3538 filter.description => $form->{filter}->{description}
3540 3. array+hashref access
3542 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3543 using [+] instead of [] will force a new array index. this is useful for recurring
3544 data structures like part lists. put a [+] into the first varname, and use [] on the
3547 repeating these names in your template:
3550 invoice.items[].parts_id
3554 $form->{invoice}->{items}->[
3568 using brackets at the end of a name will result in a pure array to be created.
3569 note that you mustn't use [+], which is reserved for array+hash access and will
3570 result in undefined behaviour in array context.
3572 filter.status[] => $form->{status}->[ val1, val2, ... ]
3574 =head2 C<update_business> PARAMS
3577 \%config, - config hashref
3578 $business_id, - business id
3579 $dbh - optional database handle
3581 handles business (thats customer/vendor types) sequences.
3583 special behaviour for empty strings in customerinitnumber field:
3584 will in this case not increase the value, and return undef.
3586 =head2 C<redirect_header> $url
3588 Generates a HTTP redirection header for the new C<$url>. Constructs an
3589 absolute URL including scheme, host name and port. If C<$url> is a
3590 relative URL then it is considered relative to Lx-Office base URL.
3592 This function C<die>s if headers have already been created with
3593 C<$::form-E<gt>header>.
3597 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3598 print $::form->redirect_header('http://www.lx-office.org/');
3602 Generates a general purpose http/html header and includes most of the scripts
3603 ans stylesheets needed.
3605 Only one header will be generated. If the method was already called in this
3606 request it will not output anything and return undef. Also if no
3607 HTTP_USER_AGENT is found, no header is generated.
3609 Although header does not accept parameters itself, it will honor special
3610 hashkeys of its Form instance:
3618 If one of these is set, a http-equiv refresh is generated. Missing parameters
3619 default to 3 seconds and the refering url.
3625 If these are arrayrefs the contents will be inlined into the header.
3629 If true, a css snippet will be generated that sets the page in landscape mode.
3633 Used to override the default favicon.
3637 A html page title will be generated from this