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 <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
684 <script type="text/javascript" src="js/tabcontent.js">
686 /***********************************************
687 * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
688 * This notice MUST stay intact for legal use
689 * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
690 ***********************************************/
699 $::lxdebug->leave_sub;
702 sub ajax_response_header {
703 $main::lxdebug->enter_sub();
707 my $db_charset = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
708 my $cgi = $main::cgi || CGI->new('');
709 my $output = $cgi->header('-charset' => $db_charset);
711 $main::lxdebug->leave_sub();
716 sub redirect_header {
720 my $base_uri = $self->_get_request_uri;
721 my $new_uri = URI->new_abs($new_url, $base_uri);
723 die "Headers already sent" if $::self->{header};
726 my $cgi = $main::cgi || CGI->new('');
727 return $cgi->redirect($new_uri);
730 sub set_standard_title {
731 $::lxdebug->enter_sub;
734 $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
735 $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
736 $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
738 $::lxdebug->leave_sub;
741 sub _prepare_html_template {
742 $main::lxdebug->enter_sub();
744 my ($self, $file, $additional_params) = @_;
747 if (!%::myconfig || !$::myconfig{"countrycode"}) {
748 $language = $main::language;
750 $language = $main::myconfig{"countrycode"};
752 $language = "de" unless ($language);
754 if (-f "templates/webpages/${file}.html") {
755 if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
756 my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
757 "Please re-run 'locales.pl' in 'locale/${language}'.";
758 print(qq|<pre>$info</pre>|);
762 $file = "templates/webpages/${file}.html";
765 my $info = "Web page template '${file}' not found.\n";
766 print qq|<pre>$info</pre>|;
770 if ($self->{"DEBUG"}) {
771 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
774 if ($additional_params->{"DEBUG"}) {
775 $additional_params->{"DEBUG"} =
776 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
779 if (%main::myconfig) {
780 $::myconfig{jsc_dateformat} = apply {
784 } $::myconfig{"dateformat"};
785 $additional_params->{"myconfig"} ||= \%::myconfig;
786 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
789 $additional_params->{"conf_dbcharset"} = $::dbcharset;
790 $additional_params->{"conf_webdav"} = $::webdav;
791 $additional_params->{"conf_lizenzen"} = $::lizenzen;
792 $additional_params->{"conf_latex_templates"} = $::latex;
793 $additional_params->{"conf_opendocument_templates"} = $::opendocument_templates;
794 $additional_params->{"conf_vertreter"} = $::vertreter;
795 $additional_params->{"conf_show_best_before"} = $::show_best_before;
796 $additional_params->{"conf_parts_image_css"} = $::parts_image_css;
797 $additional_params->{"conf_parts_listing_images"} = $::parts_listing_images;
798 $additional_params->{"conf_parts_show_image"} = $::parts_show_image;
800 if (%main::debug_options) {
801 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
804 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
805 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
806 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
810 $main::lxdebug->leave_sub();
815 sub parse_html_template {
816 $main::lxdebug->enter_sub();
818 my ($self, $file, $additional_params) = @_;
820 $additional_params ||= { };
822 my $real_file = $self->_prepare_html_template($file, $additional_params);
823 my $template = $self->template || $self->init_template;
825 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
828 $template->process($real_file, $additional_params, \$output) || die $template->error;
830 $main::lxdebug->leave_sub();
838 return if $self->template;
840 return $self->template(Template->new({
845 'PLUGIN_BASE' => 'SL::Template::Plugin',
846 'INCLUDE_PATH' => '.:templates/webpages',
847 'COMPILE_EXT' => '.tcc',
848 'COMPILE_DIR' => $::userspath . '/templates-cache',
854 $self->{template_object} = shift if @_;
855 return $self->{template_object};
858 sub show_generic_error {
859 $main::lxdebug->enter_sub();
861 my ($self, $error, %params) = @_;
864 'title_error' => $params{title},
865 'label_error' => $error,
868 if ($params{action}) {
871 map { delete($self->{$_}); } qw(action);
872 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
874 $add_params->{SHOW_BUTTON} = 1;
875 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
876 $add_params->{VARIABLES} = \@vars;
878 } elsif ($params{back_button}) {
879 $add_params->{SHOW_BACK_BUTTON} = 1;
882 $self->{title} = $params{title} if $params{title};
885 print $self->parse_html_template("generic/error", $add_params);
887 print STDERR "Error: $error\n";
889 $main::lxdebug->leave_sub();
894 sub show_generic_information {
895 $main::lxdebug->enter_sub();
897 my ($self, $text, $title) = @_;
900 'title_information' => $title,
901 'label_information' => $text,
904 $self->{title} = $title if ($title);
907 print $self->parse_html_template("generic/information", $add_params);
909 $main::lxdebug->leave_sub();
914 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
915 # changed it to accept an arbitrary number of triggers - sschoeling
917 $main::lxdebug->enter_sub();
920 my $myconfig = shift;
923 # set dateform for jsscript
926 "dd.mm.yy" => "%d.%m.%Y",
927 "dd-mm-yy" => "%d-%m-%Y",
928 "dd/mm/yy" => "%d/%m/%Y",
929 "mm/dd/yy" => "%m/%d/%Y",
930 "mm-dd-yy" => "%m-%d-%Y",
931 "yyyy-mm-dd" => "%Y-%m-%d",
934 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
935 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
942 inputField : "| . (shift) . qq|",
943 ifFormat :"$ifFormat",
944 align : "| . (shift) . qq|",
945 button : "| . (shift) . qq|"
951 <script type="text/javascript">
952 <!--| . join("", @triggers) . qq|//-->
956 $main::lxdebug->leave_sub();
959 } #end sub write_trigger
962 $main::lxdebug->enter_sub();
964 my ($self, $msg) = @_;
966 if (!$self->{callback}) {
972 # my ($script, $argv) = split(/\?/, $self->{callback}, 2);
973 # $script =~ s|.*/||;
974 # $script =~ s|[^a-zA-Z0-9_\.]||g;
975 # exec("perl", "$script", $argv);
977 print $::form->redirect_header($self->{callback});
979 $main::lxdebug->leave_sub();
982 # sort of columns removed - empty sub
984 $main::lxdebug->enter_sub();
986 my ($self, @columns) = @_;
988 $main::lxdebug->leave_sub();
994 $main::lxdebug->enter_sub(2);
996 my ($self, $myconfig, $amount, $places, $dash) = @_;
1002 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1004 my $neg = ($amount =~ s/^-//);
1005 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1007 if (defined($places) && ($places ne '')) {
1013 my ($actual_places) = ($amount =~ /\.(\d+)/);
1014 $actual_places = length($actual_places);
1015 $places = $actual_places > $places ? $actual_places : $places;
1018 $amount = $self->round_amount($amount, $places);
1021 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1022 my @p = split(/\./, $amount); # split amount at decimal point
1024 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1027 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1030 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1031 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1032 ($neg ? "-$amount" : "$amount" ) ;
1036 $main::lxdebug->leave_sub(2);
1040 sub format_amount_units {
1041 $main::lxdebug->enter_sub();
1046 my $myconfig = \%main::myconfig;
1047 my $amount = $params{amount} * 1;
1048 my $places = $params{places};
1049 my $part_unit_name = $params{part_unit};
1050 my $amount_unit_name = $params{amount_unit};
1051 my $conv_units = $params{conv_units};
1052 my $max_places = $params{max_places};
1054 if (!$part_unit_name) {
1055 $main::lxdebug->leave_sub();
1059 AM->retrieve_all_units();
1060 my $all_units = $main::all_units;
1062 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1063 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1066 if (!scalar @{ $conv_units }) {
1067 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1068 $main::lxdebug->leave_sub();
1072 my $part_unit = $all_units->{$part_unit_name};
1073 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1075 $amount *= $conv_unit->{factor};
1080 foreach my $unit (@$conv_units) {
1081 my $last = $unit->{name} eq $part_unit->{name};
1083 $num = int($amount / $unit->{factor});
1084 $amount -= $num * $unit->{factor};
1087 if ($last ? $amount : $num) {
1088 push @values, { "unit" => $unit->{name},
1089 "amount" => $last ? $amount / $unit->{factor} : $num,
1090 "places" => $last ? $places : 0 };
1097 push @values, { "unit" => $part_unit_name,
1102 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1104 $main::lxdebug->leave_sub();
1110 $main::lxdebug->enter_sub(2);
1115 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1116 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1117 $input =~ s/\#\#/\#/g;
1119 $main::lxdebug->leave_sub(2);
1127 $main::lxdebug->enter_sub(2);
1129 my ($self, $myconfig, $amount) = @_;
1131 if ( ($myconfig->{numberformat} eq '1.000,00')
1132 || ($myconfig->{numberformat} eq '1000,00')) {
1137 if ($myconfig->{numberformat} eq "1'000.00") {
1143 $main::lxdebug->leave_sub(2);
1145 return ($amount * 1);
1149 $main::lxdebug->enter_sub(2);
1151 my ($self, $amount, $places) = @_;
1154 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1156 # Round amounts to eight places before rounding to the requested
1157 # number of places. This gets rid of errors due to internal floating
1158 # point representation.
1159 $amount = $self->round_amount($amount, 8) if $places < 8;
1160 $amount = $amount * (10**($places));
1161 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1163 $main::lxdebug->leave_sub(2);
1165 return $round_amount;
1169 sub parse_template {
1170 $main::lxdebug->enter_sub();
1172 my ($self, $myconfig, $userspath) = @_;
1177 $self->{"cwd"} = getcwd();
1178 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1183 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1184 $template_type = 'OpenDocument';
1185 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1187 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1188 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1189 $template_type = 'LaTeX';
1190 $ext_for_format = 'pdf';
1192 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1193 $template_type = 'HTML';
1194 $ext_for_format = 'html';
1196 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1197 $template_type = 'XML';
1198 $ext_for_format = 'xml';
1200 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1201 $template_type = 'XML';
1203 } elsif ( $self->{"format"} =~ /excel/i ) {
1204 $template_type = 'Excel';
1205 $ext_for_format = 'xls';
1207 } elsif ( defined $self->{'format'}) {
1208 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1210 } elsif ( $self->{'format'} eq '' ) {
1211 $self->error("No Outputformat given: $self->{'format'}");
1213 } else { #Catch the rest
1214 $self->error("Outputformat not defined: $self->{'format'}");
1217 my $template = SL::Template::create(type => $template_type,
1218 file_name => $self->{IN},
1220 myconfig => $myconfig,
1221 userspath => $userspath);
1223 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1224 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1226 if (!$self->{employee_id}) {
1227 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1230 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1232 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1234 # OUT is used for the media, screen, printer, email
1235 # for postscript we store a copy in a temporary file
1237 my $prepend_userspath;
1239 if (!$self->{tmpfile}) {
1240 $self->{tmpfile} = "${fileid}.$self->{IN}";
1241 $prepend_userspath = 1;
1244 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1246 $self->{tmpfile} =~ s|.*/||;
1247 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1248 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1250 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1251 $out = $self->{OUT};
1252 $self->{OUT} = ">$self->{tmpfile}";
1258 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1259 $result = $template->parse(*OUT);
1264 $result = $template->parse(*STDOUT);
1269 $self->error("$self->{IN} : " . $template->get_error());
1272 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1274 if ($self->{media} eq 'email') {
1276 my $mail = new Mailer;
1278 map { $mail->{$_} = $self->{$_} }
1279 qw(cc bcc subject message version format);
1280 $mail->{charset} = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
1281 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1282 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1283 $mail->{fileid} = "$fileid.";
1284 $myconfig->{signature} =~ s/\r//g;
1286 # if we send html or plain text inline
1287 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1288 $mail->{contenttype} = "text/html";
1290 $mail->{message} =~ s/\r//g;
1291 $mail->{message} =~ s/\n/<br>\n/g;
1292 $myconfig->{signature} =~ s/\n/<br>\n/g;
1293 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1295 open(IN, $self->{tmpfile})
1296 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1298 $mail->{message} .= $_;
1305 if (!$self->{"do_not_attach"}) {
1306 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1307 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1308 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1309 "name" => $attachment_name }];
1312 $mail->{message} =~ s/\r//g;
1313 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1317 my $err = $mail->send();
1318 $self->error($self->cleanup . "$err") if ($err);
1322 $self->{OUT} = $out;
1324 my $numbytes = (-s $self->{tmpfile});
1325 open(IN, $self->{tmpfile})
1326 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1328 $self->{copies} = 1 unless $self->{media} eq 'printer';
1330 chdir("$self->{cwd}");
1331 #print(STDERR "Kopien $self->{copies}\n");
1332 #print(STDERR "OUT $self->{OUT}\n");
1333 for my $i (1 .. $self->{copies}) {
1335 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1336 print OUT while <IN>;
1341 $self->{attachment_filename} = ($self->{attachment_filename})
1342 ? $self->{attachment_filename}
1343 : $self->generate_attachment_filename();
1345 # launch application
1346 print qq|Content-Type: | . $template->get_mime_type() . qq|
1347 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1348 Content-Length: $numbytes
1352 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1363 chdir("$self->{cwd}");
1364 $main::lxdebug->leave_sub();
1367 sub get_formname_translation {
1368 $main::lxdebug->enter_sub();
1369 my ($self, $formname) = @_;
1371 $formname ||= $self->{formname};
1373 my %formname_translations = (
1374 bin_list => $main::locale->text('Bin List'),
1375 credit_note => $main::locale->text('Credit Note'),
1376 invoice => $main::locale->text('Invoice'),
1377 pick_list => $main::locale->text('Pick List'),
1378 proforma => $main::locale->text('Proforma Invoice'),
1379 purchase_order => $main::locale->text('Purchase Order'),
1380 request_quotation => $main::locale->text('RFQ'),
1381 sales_order => $main::locale->text('Confirmation'),
1382 sales_quotation => $main::locale->text('Quotation'),
1383 storno_invoice => $main::locale->text('Storno Invoice'),
1384 sales_delivery_order => $main::locale->text('Delivery Order'),
1385 purchase_delivery_order => $main::locale->text('Delivery Order'),
1386 dunning => $main::locale->text('Dunning'),
1389 $main::lxdebug->leave_sub();
1390 return $formname_translations{$formname}
1393 sub get_number_prefix_for_type {
1394 $main::lxdebug->enter_sub();
1398 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1399 : ($self->{type} =~ /_quotation$/) ? 'quo'
1400 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1403 $main::lxdebug->leave_sub();
1407 sub get_extension_for_format {
1408 $main::lxdebug->enter_sub();
1411 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1412 : $self->{format} =~ /postscript/i ? ".ps"
1413 : $self->{format} =~ /opendocument/i ? ".odt"
1414 : $self->{format} =~ /excel/i ? ".xls"
1415 : $self->{format} =~ /html/i ? ".html"
1418 $main::lxdebug->leave_sub();
1422 sub generate_attachment_filename {
1423 $main::lxdebug->enter_sub();
1426 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1427 my $prefix = $self->get_number_prefix_for_type();
1429 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1430 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1432 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1433 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1436 $attachment_filename = "";
1439 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1440 $attachment_filename =~ s|[\s/\\]+|_|g;
1442 $main::lxdebug->leave_sub();
1443 return $attachment_filename;
1446 sub generate_email_subject {
1447 $main::lxdebug->enter_sub();
1450 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1451 my $prefix = $self->get_number_prefix_for_type();
1453 if ($subject && $self->{"${prefix}number"}) {
1454 $subject .= " " . $self->{"${prefix}number"}
1457 $main::lxdebug->leave_sub();
1462 $main::lxdebug->enter_sub();
1466 chdir("$self->{tmpdir}");
1469 if (-f "$self->{tmpfile}.err") {
1470 open(FH, "$self->{tmpfile}.err");
1475 if ($self->{tmpfile} && ! $::keep_temp_files) {
1476 $self->{tmpfile} =~ s|.*/||g;
1478 $self->{tmpfile} =~ s/\.\w+$//g;
1479 my $tmpfile = $self->{tmpfile};
1480 unlink(<$tmpfile.*>);
1483 chdir("$self->{cwd}");
1485 $main::lxdebug->leave_sub();
1491 $main::lxdebug->enter_sub();
1493 my ($self, $date, $myconfig) = @_;
1496 if ($date && $date =~ /\D/) {
1498 if ($myconfig->{dateformat} =~ /^yy/) {
1499 ($yy, $mm, $dd) = split /\D/, $date;
1501 if ($myconfig->{dateformat} =~ /^mm/) {
1502 ($mm, $dd, $yy) = split /\D/, $date;
1504 if ($myconfig->{dateformat} =~ /^dd/) {
1505 ($dd, $mm, $yy) = split /\D/, $date;
1510 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1511 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1513 $dd = "0$dd" if ($dd < 10);
1514 $mm = "0$mm" if ($mm < 10);
1516 $date = "$yy$mm$dd";
1519 $main::lxdebug->leave_sub();
1524 # Database routines used throughout
1526 sub _dbconnect_options {
1528 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1535 $main::lxdebug->enter_sub(2);
1537 my ($self, $myconfig) = @_;
1539 # connect to database
1540 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1544 if ($myconfig->{dboptions}) {
1545 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1548 $main::lxdebug->leave_sub(2);
1553 sub dbconnect_noauto {
1554 $main::lxdebug->enter_sub();
1556 my ($self, $myconfig) = @_;
1558 # connect to database
1559 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1563 if ($myconfig->{dboptions}) {
1564 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1567 $main::lxdebug->leave_sub();
1572 sub get_standard_dbh {
1573 $main::lxdebug->enter_sub(2);
1576 my $myconfig = shift || \%::myconfig;
1578 if ($standard_dbh && !$standard_dbh->{Active}) {
1579 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1580 undef $standard_dbh;
1583 $standard_dbh ||= SL::DB::create->dbh;
1585 $main::lxdebug->leave_sub(2);
1587 return $standard_dbh;
1591 $main::lxdebug->enter_sub();
1593 my ($self, $date, $myconfig) = @_;
1594 my $dbh = $self->dbconnect($myconfig);
1596 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1597 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1598 my ($closed) = $sth->fetchrow_array;
1600 $main::lxdebug->leave_sub();
1605 sub update_balance {
1606 $main::lxdebug->enter_sub();
1608 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1610 # if we have a value, go do it
1613 # retrieve balance from table
1614 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1615 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1616 my ($balance) = $sth->fetchrow_array;
1622 $query = "UPDATE $table SET $field = $balance WHERE $where";
1623 do_query($self, $dbh, $query, @values);
1625 $main::lxdebug->leave_sub();
1628 sub update_exchangerate {
1629 $main::lxdebug->enter_sub();
1631 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1633 # some sanity check for currency
1635 $main::lxdebug->leave_sub();
1638 $query = qq|SELECT curr FROM defaults|;
1640 my ($currency) = selectrow_query($self, $dbh, $query);
1641 my ($defaultcurrency) = split m/:/, $currency;
1644 if ($curr eq $defaultcurrency) {
1645 $main::lxdebug->leave_sub();
1649 $query = qq|SELECT e.curr FROM exchangerate e
1650 WHERE e.curr = ? AND e.transdate = ?
1652 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1661 $buy = conv_i($buy, "NULL");
1662 $sell = conv_i($sell, "NULL");
1665 if ($buy != 0 && $sell != 0) {
1666 $set = "buy = $buy, sell = $sell";
1667 } elsif ($buy != 0) {
1668 $set = "buy = $buy";
1669 } elsif ($sell != 0) {
1670 $set = "sell = $sell";
1673 if ($sth->fetchrow_array) {
1674 $query = qq|UPDATE exchangerate
1680 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1681 VALUES (?, $buy, $sell, ?)|;
1684 do_query($self, $dbh, $query, $curr, $transdate);
1686 $main::lxdebug->leave_sub();
1689 sub save_exchangerate {
1690 $main::lxdebug->enter_sub();
1692 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1694 my $dbh = $self->dbconnect($myconfig);
1698 $buy = $rate if $fld eq 'buy';
1699 $sell = $rate if $fld eq 'sell';
1702 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1707 $main::lxdebug->leave_sub();
1710 sub get_exchangerate {
1711 $main::lxdebug->enter_sub();
1713 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1716 unless ($transdate) {
1717 $main::lxdebug->leave_sub();
1721 $query = qq|SELECT curr FROM defaults|;
1723 my ($currency) = selectrow_query($self, $dbh, $query);
1724 my ($defaultcurrency) = split m/:/, $currency;
1726 if ($currency eq $defaultcurrency) {
1727 $main::lxdebug->leave_sub();
1731 $query = qq|SELECT e.$fld FROM exchangerate e
1732 WHERE e.curr = ? AND e.transdate = ?|;
1733 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1737 $main::lxdebug->leave_sub();
1739 return $exchangerate;
1742 sub check_exchangerate {
1743 $main::lxdebug->enter_sub();
1745 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1747 if ($fld !~/^buy|sell$/) {
1748 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1751 unless ($transdate) {
1752 $main::lxdebug->leave_sub();
1756 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1758 if ($currency eq $defaultcurrency) {
1759 $main::lxdebug->leave_sub();
1763 my $dbh = $self->get_standard_dbh($myconfig);
1764 my $query = qq|SELECT e.$fld FROM exchangerate e
1765 WHERE e.curr = ? AND e.transdate = ?|;
1767 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1769 $main::lxdebug->leave_sub();
1771 return $exchangerate;
1774 sub get_all_currencies {
1775 $main::lxdebug->enter_sub();
1778 my $myconfig = shift || \%::myconfig;
1779 my $dbh = $self->get_standard_dbh($myconfig);
1781 my $query = qq|SELECT curr FROM defaults|;
1783 my ($curr) = selectrow_query($self, $dbh, $query);
1784 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1786 $main::lxdebug->leave_sub();
1791 sub get_default_currency {
1792 $main::lxdebug->enter_sub();
1794 my ($self, $myconfig) = @_;
1795 my @currencies = $self->get_all_currencies($myconfig);
1797 $main::lxdebug->leave_sub();
1799 return $currencies[0];
1802 sub set_payment_options {
1803 $main::lxdebug->enter_sub();
1805 my ($self, $myconfig, $transdate) = @_;
1807 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1809 my $dbh = $self->get_standard_dbh($myconfig);
1812 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1813 qq|FROM payment_terms p | .
1816 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1817 $self->{payment_terms}) =
1818 selectrow_query($self, $dbh, $query, $self->{payment_id});
1820 if ($transdate eq "") {
1821 if ($self->{invdate}) {
1822 $transdate = $self->{invdate};
1824 $transdate = $self->{transdate};
1829 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1830 qq|FROM payment_terms|;
1831 ($self->{netto_date}, $self->{skonto_date}) =
1832 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1834 my ($invtotal, $total);
1835 my (%amounts, %formatted_amounts);
1837 if ($self->{type} =~ /_order$/) {
1838 $amounts{invtotal} = $self->{ordtotal};
1839 $amounts{total} = $self->{ordtotal};
1841 } elsif ($self->{type} =~ /_quotation$/) {
1842 $amounts{invtotal} = $self->{quototal};
1843 $amounts{total} = $self->{quototal};
1846 $amounts{invtotal} = $self->{invtotal};
1847 $amounts{total} = $self->{total};
1849 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1851 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1853 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1854 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1855 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1857 foreach (keys %amounts) {
1858 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1859 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1862 if ($self->{"language_id"}) {
1864 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1865 qq|FROM translation_payment_terms t | .
1866 qq|LEFT JOIN language l ON t.language_id = l.id | .
1867 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1868 my ($description_long, $output_numberformat, $output_dateformat,
1869 $output_longdates) =
1870 selectrow_query($self, $dbh, $query,
1871 $self->{"language_id"}, $self->{"payment_id"});
1873 $self->{payment_terms} = $description_long if ($description_long);
1875 if ($output_dateformat) {
1876 foreach my $key (qw(netto_date skonto_date)) {
1878 $main::locale->reformat_date($myconfig, $self->{$key},
1884 if ($output_numberformat &&
1885 ($output_numberformat ne $myconfig->{"numberformat"})) {
1886 my $saved_numberformat = $myconfig->{"numberformat"};
1887 $myconfig->{"numberformat"} = $output_numberformat;
1888 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1889 $myconfig->{"numberformat"} = $saved_numberformat;
1893 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1894 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1895 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1896 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1897 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1898 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1899 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1901 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1903 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1905 $main::lxdebug->leave_sub();
1909 sub get_template_language {
1910 $main::lxdebug->enter_sub();
1912 my ($self, $myconfig) = @_;
1914 my $template_code = "";
1916 if ($self->{language_id}) {
1917 my $dbh = $self->get_standard_dbh($myconfig);
1918 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1919 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1922 $main::lxdebug->leave_sub();
1924 return $template_code;
1927 sub get_printer_code {
1928 $main::lxdebug->enter_sub();
1930 my ($self, $myconfig) = @_;
1932 my $template_code = "";
1934 if ($self->{printer_id}) {
1935 my $dbh = $self->get_standard_dbh($myconfig);
1936 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1937 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1940 $main::lxdebug->leave_sub();
1942 return $template_code;
1946 $main::lxdebug->enter_sub();
1948 my ($self, $myconfig) = @_;
1950 my $template_code = "";
1952 if ($self->{shipto_id}) {
1953 my $dbh = $self->get_standard_dbh($myconfig);
1954 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1955 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1956 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1959 $main::lxdebug->leave_sub();
1963 $main::lxdebug->enter_sub();
1965 my ($self, $dbh, $id, $module) = @_;
1970 foreach my $item (qw(name department_1 department_2 street zipcode city country
1971 contact cp_gender phone fax email)) {
1972 if ($self->{"shipto$item"}) {
1973 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1975 push(@values, $self->{"shipto${item}"});
1979 if ($self->{shipto_id}) {
1980 my $query = qq|UPDATE shipto set
1982 shiptodepartment_1 = ?,
1983 shiptodepartment_2 = ?,
1989 shiptocp_gender = ?,
1993 WHERE shipto_id = ?|;
1994 do_query($self, $dbh, $query, @values, $self->{shipto_id});
1996 my $query = qq|SELECT * FROM shipto
1997 WHERE shiptoname = ? AND
1998 shiptodepartment_1 = ? AND
1999 shiptodepartment_2 = ? AND
2000 shiptostreet = ? AND
2001 shiptozipcode = ? AND
2003 shiptocountry = ? AND
2004 shiptocontact = ? AND
2005 shiptocp_gender = ? AND
2011 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2014 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2015 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2016 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2017 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2018 do_query($self, $dbh, $query, $id, @values, $module);
2023 $main::lxdebug->leave_sub();
2027 $main::lxdebug->enter_sub();
2029 my ($self, $dbh) = @_;
2031 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2033 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2034 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2035 $self->{"employee_id"} *= 1;
2037 $main::lxdebug->leave_sub();
2040 sub get_employee_data {
2041 $main::lxdebug->enter_sub();
2046 Common::check_params(\%params, qw(prefix));
2047 Common::check_params_x(\%params, qw(id));
2050 $main::lxdebug->leave_sub();
2054 my $myconfig = \%main::myconfig;
2055 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2057 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2060 my $user = User->new($login);
2061 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2063 $self->{$params{prefix} . '_login'} = $login;
2064 $self->{$params{prefix} . '_name'} ||= $login;
2067 $main::lxdebug->leave_sub();
2071 $main::lxdebug->enter_sub();
2073 my ($self, $myconfig, $reference_date) = @_;
2075 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2077 my $dbh = $self->get_standard_dbh($myconfig);
2078 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2079 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2081 $main::lxdebug->leave_sub();
2087 $main::lxdebug->enter_sub();
2089 my ($self, $dbh, $id, $key) = @_;
2091 $key = "all_contacts" unless ($key);
2095 $main::lxdebug->leave_sub();
2100 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2101 qq|FROM contacts | .
2102 qq|WHERE cp_cv_id = ? | .
2103 qq|ORDER BY lower(cp_name)|;
2105 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2107 $main::lxdebug->leave_sub();
2111 $main::lxdebug->enter_sub();
2113 my ($self, $dbh, $key) = @_;
2115 my ($all, $old_id, $where, @values);
2117 if (ref($key) eq "HASH") {
2120 $key = "ALL_PROJECTS";
2122 foreach my $p (keys(%{$params})) {
2124 $all = $params->{$p};
2125 } elsif ($p eq "old_id") {
2126 $old_id = $params->{$p};
2127 } elsif ($p eq "key") {
2128 $key = $params->{$p};
2134 $where = "WHERE active ";
2136 if (ref($old_id) eq "ARRAY") {
2137 my @ids = grep({ $_ } @{$old_id});
2139 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2140 push(@values, @ids);
2143 $where .= " OR (id = ?) ";
2144 push(@values, $old_id);
2150 qq|SELECT id, projectnumber, description, active | .
2153 qq|ORDER BY lower(projectnumber)|;
2155 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2157 $main::lxdebug->leave_sub();
2161 $main::lxdebug->enter_sub();
2163 my ($self, $dbh, $vc_id, $key) = @_;
2165 $key = "all_shipto" unless ($key);
2168 # get shipping addresses
2169 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2171 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2177 $main::lxdebug->leave_sub();
2181 $main::lxdebug->enter_sub();
2183 my ($self, $dbh, $key) = @_;
2185 $key = "all_printers" unless ($key);
2187 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2189 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2191 $main::lxdebug->leave_sub();
2195 $main::lxdebug->enter_sub();
2197 my ($self, $dbh, $params) = @_;
2200 $key = $params->{key};
2201 $key = "all_charts" unless ($key);
2203 my $transdate = quote_db_date($params->{transdate});
2206 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2208 qq|LEFT JOIN taxkeys tk ON | .
2209 qq|(tk.id = (SELECT id FROM taxkeys | .
2210 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2211 qq| ORDER BY startdate DESC LIMIT 1)) | .
2212 qq|ORDER BY c.accno|;
2214 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2216 $main::lxdebug->leave_sub();
2219 sub _get_taxcharts {
2220 $main::lxdebug->enter_sub();
2222 my ($self, $dbh, $params) = @_;
2224 my $key = "all_taxcharts";
2227 if (ref $params eq 'HASH') {
2228 $key = $params->{key} if ($params->{key});
2229 if ($params->{module} eq 'AR') {
2230 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2232 } elsif ($params->{module} eq 'AP') {
2233 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2240 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2242 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2244 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2246 $main::lxdebug->leave_sub();
2250 $main::lxdebug->enter_sub();
2252 my ($self, $dbh, $key) = @_;
2254 $key = "all_taxzones" unless ($key);
2256 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2258 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2260 $main::lxdebug->leave_sub();
2263 sub _get_employees {
2264 $main::lxdebug->enter_sub();
2266 my ($self, $dbh, $default_key, $key) = @_;
2268 $key = $default_key unless ($key);
2269 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2271 $main::lxdebug->leave_sub();
2274 sub _get_business_types {
2275 $main::lxdebug->enter_sub();
2277 my ($self, $dbh, $key) = @_;
2279 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2280 $options->{key} ||= "all_business_types";
2283 if (exists $options->{salesman}) {
2284 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2287 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2289 $main::lxdebug->leave_sub();
2292 sub _get_languages {
2293 $main::lxdebug->enter_sub();
2295 my ($self, $dbh, $key) = @_;
2297 $key = "all_languages" unless ($key);
2299 my $query = qq|SELECT * FROM language ORDER BY id|;
2301 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2303 $main::lxdebug->leave_sub();
2306 sub _get_dunning_configs {
2307 $main::lxdebug->enter_sub();
2309 my ($self, $dbh, $key) = @_;
2311 $key = "all_dunning_configs" unless ($key);
2313 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2315 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2317 $main::lxdebug->leave_sub();
2320 sub _get_currencies {
2321 $main::lxdebug->enter_sub();
2323 my ($self, $dbh, $key) = @_;
2325 $key = "all_currencies" unless ($key);
2327 my $query = qq|SELECT curr AS currency FROM defaults|;
2329 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2331 $main::lxdebug->leave_sub();
2335 $main::lxdebug->enter_sub();
2337 my ($self, $dbh, $key) = @_;
2339 $key = "all_payments" unless ($key);
2341 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2343 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2345 $main::lxdebug->leave_sub();
2348 sub _get_customers {
2349 $main::lxdebug->enter_sub();
2351 my ($self, $dbh, $key) = @_;
2353 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2354 $options->{key} ||= "all_customers";
2355 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2358 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2359 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2360 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2362 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2363 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2365 $main::lxdebug->leave_sub();
2369 $main::lxdebug->enter_sub();
2371 my ($self, $dbh, $key) = @_;
2373 $key = "all_vendors" unless ($key);
2375 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2377 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2379 $main::lxdebug->leave_sub();
2382 sub _get_departments {
2383 $main::lxdebug->enter_sub();
2385 my ($self, $dbh, $key) = @_;
2387 $key = "all_departments" unless ($key);
2389 my $query = qq|SELECT * FROM department ORDER BY description|;
2391 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2393 $main::lxdebug->leave_sub();
2396 sub _get_warehouses {
2397 $main::lxdebug->enter_sub();
2399 my ($self, $dbh, $param) = @_;
2401 my ($key, $bins_key);
2403 if ('' eq ref $param) {
2407 $key = $param->{key};
2408 $bins_key = $param->{bins};
2411 my $query = qq|SELECT w.* FROM warehouse w
2412 WHERE (NOT w.invalid) AND
2413 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2414 ORDER BY w.sortkey|;
2416 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2419 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2420 my $sth = prepare_query($self, $dbh, $query);
2422 foreach my $warehouse (@{ $self->{$key} }) {
2423 do_statement($self, $sth, $query, $warehouse->{id});
2424 $warehouse->{$bins_key} = [];
2426 while (my $ref = $sth->fetchrow_hashref()) {
2427 push @{ $warehouse->{$bins_key} }, $ref;
2433 $main::lxdebug->leave_sub();
2437 $main::lxdebug->enter_sub();
2439 my ($self, $dbh, $table, $key, $sortkey) = @_;
2441 my $query = qq|SELECT * FROM $table|;
2442 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2444 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2446 $main::lxdebug->leave_sub();
2450 # $main::lxdebug->enter_sub();
2452 # my ($self, $dbh, $key) = @_;
2454 # $key ||= "all_groups";
2456 # my $groups = $main::auth->read_groups();
2458 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2460 # $main::lxdebug->leave_sub();
2464 $main::lxdebug->enter_sub();
2469 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2470 my ($sth, $query, $ref);
2472 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2473 my $vc_id = $self->{"${vc}_id"};
2475 if ($params{"contacts"}) {
2476 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2479 if ($params{"shipto"}) {
2480 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2483 if ($params{"projects"} || $params{"all_projects"}) {
2484 $self->_get_projects($dbh, $params{"all_projects"} ?
2485 $params{"all_projects"} : $params{"projects"},
2486 $params{"all_projects"} ? 1 : 0);
2489 if ($params{"printers"}) {
2490 $self->_get_printers($dbh, $params{"printers"});
2493 if ($params{"languages"}) {
2494 $self->_get_languages($dbh, $params{"languages"});
2497 if ($params{"charts"}) {
2498 $self->_get_charts($dbh, $params{"charts"});
2501 if ($params{"taxcharts"}) {
2502 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2505 if ($params{"taxzones"}) {
2506 $self->_get_taxzones($dbh, $params{"taxzones"});
2509 if ($params{"employees"}) {
2510 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2513 if ($params{"salesmen"}) {
2514 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2517 if ($params{"business_types"}) {
2518 $self->_get_business_types($dbh, $params{"business_types"});
2521 if ($params{"dunning_configs"}) {
2522 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2525 if($params{"currencies"}) {
2526 $self->_get_currencies($dbh, $params{"currencies"});
2529 if($params{"customers"}) {
2530 $self->_get_customers($dbh, $params{"customers"});
2533 if($params{"vendors"}) {
2534 if (ref $params{"vendors"} eq 'HASH') {
2535 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2537 $self->_get_vendors($dbh, $params{"vendors"});
2541 if($params{"payments"}) {
2542 $self->_get_payments($dbh, $params{"payments"});
2545 if($params{"departments"}) {
2546 $self->_get_departments($dbh, $params{"departments"});
2549 if ($params{price_factors}) {
2550 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2553 if ($params{warehouses}) {
2554 $self->_get_warehouses($dbh, $params{warehouses});
2557 # if ($params{groups}) {
2558 # $self->_get_groups($dbh, $params{groups});
2561 if ($params{partsgroup}) {
2562 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2565 $main::lxdebug->leave_sub();
2568 # this sub gets the id and name from $table
2570 $main::lxdebug->enter_sub();
2572 my ($self, $myconfig, $table) = @_;
2574 # connect to database
2575 my $dbh = $self->get_standard_dbh($myconfig);
2577 $table = $table eq "customer" ? "customer" : "vendor";
2578 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2580 my ($query, @values);
2582 if (!$self->{openinvoices}) {
2584 if ($self->{customernumber} ne "") {
2585 $where = qq|(vc.customernumber ILIKE ?)|;
2586 push(@values, '%' . $self->{customernumber} . '%');
2588 $where = qq|(vc.name ILIKE ?)|;
2589 push(@values, '%' . $self->{$table} . '%');
2593 qq~SELECT vc.id, vc.name,
2594 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2596 WHERE $where AND (NOT vc.obsolete)
2600 qq~SELECT DISTINCT vc.id, vc.name,
2601 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2603 JOIN $table vc ON (a.${table}_id = vc.id)
2604 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2606 push(@values, '%' . $self->{$table} . '%');
2609 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2611 $main::lxdebug->leave_sub();
2613 return scalar(@{ $self->{name_list} });
2616 # the selection sub is used in the AR, AP, IS, IR and OE module
2619 $main::lxdebug->enter_sub();
2621 my ($self, $myconfig, $table, $module) = @_;
2624 my $dbh = $self->get_standard_dbh;
2626 $table = $table eq "customer" ? "customer" : "vendor";
2628 my $query = qq|SELECT count(*) FROM $table|;
2629 my ($count) = selectrow_query($self, $dbh, $query);
2631 # build selection list
2632 if ($count <= $myconfig->{vclimit}) {
2633 $query = qq|SELECT id, name, salesman_id
2634 FROM $table WHERE NOT obsolete
2636 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2640 $self->get_employee($dbh);
2642 # setup sales contacts
2643 $query = qq|SELECT e.id, e.name
2645 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2646 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2649 push(@{ $self->{all_employees} },
2650 { id => $self->{employee_id},
2651 name => $self->{employee} });
2653 # sort the whole thing
2654 @{ $self->{all_employees} } =
2655 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2657 if ($module eq 'AR') {
2659 # prepare query for departments
2660 $query = qq|SELECT id, description
2663 ORDER BY description|;
2666 $query = qq|SELECT id, description
2668 ORDER BY description|;
2671 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2674 $query = qq|SELECT id, description
2678 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2681 $query = qq|SELECT printer_description, id
2683 ORDER BY printer_description|;
2685 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2688 $query = qq|SELECT id, description
2692 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2694 $main::lxdebug->leave_sub();
2697 sub language_payment {
2698 $main::lxdebug->enter_sub();
2700 my ($self, $myconfig) = @_;
2702 my $dbh = $self->get_standard_dbh($myconfig);
2704 my $query = qq|SELECT id, description
2708 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2711 $query = qq|SELECT printer_description, id
2713 ORDER BY printer_description|;
2715 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2718 $query = qq|SELECT id, description
2722 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2724 # get buchungsgruppen
2725 $query = qq|SELECT id, description
2726 FROM buchungsgruppen|;
2728 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2730 $main::lxdebug->leave_sub();
2733 # this is only used for reports
2734 sub all_departments {
2735 $main::lxdebug->enter_sub();
2737 my ($self, $myconfig, $table) = @_;
2739 my $dbh = $self->get_standard_dbh($myconfig);
2742 if ($table eq 'customer') {
2743 $where = "WHERE role = 'P' ";
2746 my $query = qq|SELECT id, description
2749 ORDER BY description|;
2750 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2752 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2754 $main::lxdebug->leave_sub();
2758 $main::lxdebug->enter_sub();
2760 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2763 if ($table eq "customer") {
2772 $self->all_vc($myconfig, $table, $module);
2774 # get last customers or vendors
2775 my ($query, $sth, $ref);
2777 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2782 my $transdate = "current_date";
2783 if ($self->{transdate}) {
2784 $transdate = $dbh->quote($self->{transdate});
2787 # now get the account numbers
2788 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2789 FROM chart c, taxkeys tk
2790 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2791 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2794 $sth = $dbh->prepare($query);
2796 do_statement($self, $sth, $query, '%' . $module . '%');
2798 $self->{accounts} = "";
2799 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2801 foreach my $key (split(/:/, $ref->{link})) {
2802 if ($key =~ /\Q$module\E/) {
2804 # cross reference for keys
2805 $xkeyref{ $ref->{accno} } = $key;
2807 push @{ $self->{"${module}_links"}{$key} },
2808 { accno => $ref->{accno},
2809 description => $ref->{description},
2810 taxkey => $ref->{taxkey_id},
2811 tax_id => $ref->{tax_id} };
2813 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2819 # get taxkeys and description
2820 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2821 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2823 if (($module eq "AP") || ($module eq "AR")) {
2824 # get tax rates and description
2825 $query = qq|SELECT * FROM tax|;
2826 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2832 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2833 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2834 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2835 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2837 d.description AS department,
2840 JOIN $table c ON (a.${table}_id = c.id)
2841 LEFT JOIN employee e ON (e.id = a.employee_id)
2842 LEFT JOIN department d ON (d.id = a.department_id)
2844 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2846 foreach my $key (keys %$ref) {
2847 $self->{$key} = $ref->{$key};
2850 my $transdate = "current_date";
2851 if ($self->{transdate}) {
2852 $transdate = $dbh->quote($self->{transdate});
2855 # now get the account numbers
2856 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2858 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2860 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2861 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2864 $sth = $dbh->prepare($query);
2865 do_statement($self, $sth, $query, "%$module%");
2867 $self->{accounts} = "";
2868 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2870 foreach my $key (split(/:/, $ref->{link})) {
2871 if ($key =~ /\Q$module\E/) {
2873 # cross reference for keys
2874 $xkeyref{ $ref->{accno} } = $key;
2876 push @{ $self->{"${module}_links"}{$key} },
2877 { accno => $ref->{accno},
2878 description => $ref->{description},
2879 taxkey => $ref->{taxkey_id},
2880 tax_id => $ref->{tax_id} };
2882 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2888 # get amounts from individual entries
2891 c.accno, c.description,
2892 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2896 LEFT JOIN chart c ON (c.id = a.chart_id)
2897 LEFT JOIN project p ON (p.id = a.project_id)
2898 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2899 WHERE (tk.taxkey_id=a.taxkey) AND
2900 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2901 THEN tk.chart_id = a.chart_id
2904 OR (c.link='%tax%')) AND
2905 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2906 WHERE a.trans_id = ?
2907 AND a.fx_transaction = '0'
2908 ORDER BY a.acc_trans_id, a.transdate|;
2909 $sth = $dbh->prepare($query);
2910 do_statement($self, $sth, $query, $self->{id});
2912 # get exchangerate for currency
2913 $self->{exchangerate} =
2914 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2917 # store amounts in {acc_trans}{$key} for multiple accounts
2918 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2919 $ref->{exchangerate} =
2920 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2921 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2924 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2925 $ref->{amount} *= -1;
2927 $ref->{index} = $index;
2929 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2935 d.curr AS currencies, d.closedto, d.revtrans,
2936 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2937 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2939 $ref = selectfirst_hashref_query($self, $dbh, $query);
2940 map { $self->{$_} = $ref->{$_} } keys %$ref;
2947 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2948 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2949 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2951 $ref = selectfirst_hashref_query($self, $dbh, $query);
2952 map { $self->{$_} = $ref->{$_} } keys %$ref;
2954 if ($self->{"$self->{vc}_id"}) {
2956 # only setup currency
2957 ($self->{currency}) = split(/:/, $self->{currencies});
2961 $self->lastname_used($dbh, $myconfig, $table, $module);
2963 # get exchangerate for currency
2964 $self->{exchangerate} =
2965 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2971 $main::lxdebug->leave_sub();
2975 $main::lxdebug->enter_sub();
2977 my ($self, $dbh, $myconfig, $table, $module) = @_;
2981 $table = $table eq "customer" ? "customer" : "vendor";
2982 my %column_map = ("a.curr" => "currency",
2983 "a.${table}_id" => "${table}_id",
2984 "a.department_id" => "department_id",
2985 "d.description" => "department",
2986 "ct.name" => $table,
2987 "current_date + ct.terms" => "duedate",
2990 if ($self->{type} =~ /delivery_order/) {
2991 $arap = 'delivery_orders';
2992 delete $column_map{"a.curr"};
2994 } elsif ($self->{type} =~ /_order/) {
2996 $where = "quotation = '0'";
2998 } elsif ($self->{type} =~ /_quotation/) {
3000 $where = "quotation = '1'";
3002 } elsif ($table eq 'customer') {
3010 $where = "($where) AND" if ($where);
3011 my $query = qq|SELECT MAX(id) FROM $arap
3012 WHERE $where ${table}_id > 0|;
3013 my ($trans_id) = selectrow_query($self, $dbh, $query);
3016 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3017 $query = qq|SELECT $column_spec
3019 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3020 LEFT JOIN department d ON (a.department_id = d.id)
3022 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3024 map { $self->{$_} = $ref->{$_} } values %column_map;
3026 $main::lxdebug->leave_sub();
3030 $main::lxdebug->enter_sub();
3033 my $myconfig = shift || \%::myconfig;
3034 my ($thisdate, $days) = @_;
3036 my $dbh = $self->get_standard_dbh($myconfig);
3041 my $dateformat = $myconfig->{dateformat};
3042 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3043 $thisdate = $dbh->quote($thisdate);
3044 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3046 $query = qq|SELECT current_date AS thisdate|;
3049 ($thisdate) = selectrow_query($self, $dbh, $query);
3051 $main::lxdebug->leave_sub();
3057 $main::lxdebug->enter_sub();
3059 my ($self, $string) = @_;
3061 if ($string !~ /%/) {
3062 $string = "%$string%";
3065 $string =~ s/\'/\'\'/g;
3067 $main::lxdebug->leave_sub();
3073 $main::lxdebug->enter_sub();
3075 my ($self, $flds, $new, $count, $numrows) = @_;
3079 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3084 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3086 my $j = $item->{ndx} - 1;
3087 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3091 for $i ($count + 1 .. $numrows) {
3092 map { delete $self->{"${_}_$i"} } @{$flds};
3095 $main::lxdebug->leave_sub();
3099 $main::lxdebug->enter_sub();
3101 my ($self, $myconfig) = @_;
3105 my $dbh = $self->dbconnect_noauto($myconfig);
3107 my $query = qq|DELETE FROM status
3108 WHERE (formname = ?) AND (trans_id = ?)|;
3109 my $sth = prepare_query($self, $dbh, $query);
3111 if ($self->{formname} =~ /(check|receipt)/) {
3112 for $i (1 .. $self->{rowcount}) {
3113 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3116 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3120 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3121 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3123 my %queued = split / /, $self->{queued};
3126 if ($self->{formname} =~ /(check|receipt)/) {
3128 # this is a check or receipt, add one entry for each lineitem
3129 my ($accno) = split /--/, $self->{account};
3130 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3131 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3132 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3133 $sth = prepare_query($self, $dbh, $query);
3135 for $i (1 .. $self->{rowcount}) {
3136 if ($self->{"checked_$i"}) {
3137 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3143 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3144 VALUES (?, ?, ?, ?, ?)|;
3145 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3146 $queued{$self->{formname}}, $self->{formname});
3152 $main::lxdebug->leave_sub();
3156 $main::lxdebug->enter_sub();
3158 my ($self, $dbh) = @_;
3160 my ($query, $printed, $emailed);
3162 my $formnames = $self->{printed};
3163 my $emailforms = $self->{emailed};
3165 $query = qq|DELETE FROM status
3166 WHERE (formname = ?) AND (trans_id = ?)|;
3167 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3169 # this only applies to the forms
3170 # checks and receipts are posted when printed or queued
3172 if ($self->{queued}) {
3173 my %queued = split / /, $self->{queued};
3175 foreach my $formname (keys %queued) {
3176 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3177 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3179 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3180 VALUES (?, ?, ?, ?, ?)|;
3181 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3183 $formnames =~ s/\Q$self->{formname}\E//;
3184 $emailforms =~ s/\Q$self->{formname}\E//;
3189 # save printed, emailed info
3190 $formnames =~ s/^ +//g;
3191 $emailforms =~ s/^ +//g;
3194 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3195 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3197 foreach my $formname (keys %status) {
3198 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3199 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3201 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3202 VALUES (?, ?, ?, ?)|;
3203 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3206 $main::lxdebug->leave_sub();
3210 # $main::locale->text('SAVED')
3211 # $main::locale->text('DELETED')
3212 # $main::locale->text('ADDED')
3213 # $main::locale->text('PAYMENT POSTED')
3214 # $main::locale->text('POSTED')
3215 # $main::locale->text('POSTED AS NEW')
3216 # $main::locale->text('ELSE')
3217 # $main::locale->text('SAVED FOR DUNNING')
3218 # $main::locale->text('DUNNING STARTED')
3219 # $main::locale->text('PRINTED')
3220 # $main::locale->text('MAILED')
3221 # $main::locale->text('SCREENED')
3222 # $main::locale->text('CANCELED')
3223 # $main::locale->text('invoice')
3224 # $main::locale->text('proforma')
3225 # $main::locale->text('sales_order')
3226 # $main::locale->text('pick_list')
3227 # $main::locale->text('purchase_order')
3228 # $main::locale->text('bin_list')
3229 # $main::locale->text('sales_quotation')
3230 # $main::locale->text('request_quotation')
3233 $main::lxdebug->enter_sub();
3236 my $dbh = shift || $self->get_standard_dbh;
3238 if(!exists $self->{employee_id}) {
3239 &get_employee($self, $dbh);
3243 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3244 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3245 my @values = (conv_i($self->{id}), $self->{login},
3246 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3247 do_query($self, $dbh, $query, @values);
3251 $main::lxdebug->leave_sub();
3255 $main::lxdebug->enter_sub();
3257 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3258 my ($orderBy, $desc) = split(/\-\-/, $order);
3259 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3262 if ($trans_id ne "") {
3264 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 | .
3265 qq|FROM history_erp h | .
3266 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3267 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3270 my $sth = $dbh->prepare($query) || $self->dberror($query);
3272 $sth->execute() || $self->dberror("$query");
3274 while(my $hash_ref = $sth->fetchrow_hashref()) {
3275 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3276 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3277 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3278 $tempArray[$i++] = $hash_ref;
3280 $main::lxdebug->leave_sub() and return \@tempArray
3281 if ($i > 0 && $tempArray[0] ne "");
3283 $main::lxdebug->leave_sub();
3287 sub update_defaults {
3288 $main::lxdebug->enter_sub();
3290 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3293 if ($provided_dbh) {
3294 $dbh = $provided_dbh;
3296 $dbh = $self->dbconnect_noauto($myconfig);
3298 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3299 my $sth = $dbh->prepare($query);
3301 $sth->execute || $self->dberror($query);
3302 my ($var) = $sth->fetchrow_array;
3305 if ($var =~ m/\d+$/) {
3306 my $new_var = (substr $var, $-[0]) * 1 + 1;
3307 my $len_diff = length($var) - $-[0] - length($new_var);
3308 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3314 $query = qq|UPDATE defaults SET $fld = ?|;
3315 do_query($self, $dbh, $query, $var);
3317 if (!$provided_dbh) {
3322 $main::lxdebug->leave_sub();
3327 sub update_business {
3328 $main::lxdebug->enter_sub();
3330 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3333 if ($provided_dbh) {
3334 $dbh = $provided_dbh;
3336 $dbh = $self->dbconnect_noauto($myconfig);
3339 qq|SELECT customernumberinit FROM business
3340 WHERE id = ? FOR UPDATE|;
3341 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3343 return undef unless $var;
3345 if ($var =~ m/\d+$/) {
3346 my $new_var = (substr $var, $-[0]) * 1 + 1;
3347 my $len_diff = length($var) - $-[0] - length($new_var);
3348 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3354 $query = qq|UPDATE business
3355 SET customernumberinit = ?
3357 do_query($self, $dbh, $query, $var, $business_id);
3359 if (!$provided_dbh) {
3364 $main::lxdebug->leave_sub();
3369 sub get_partsgroup {
3370 $main::lxdebug->enter_sub();
3372 my ($self, $myconfig, $p) = @_;
3373 my $target = $p->{target} || 'all_partsgroup';
3375 my $dbh = $self->get_standard_dbh($myconfig);
3377 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3379 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3382 if ($p->{searchitems} eq 'part') {
3383 $query .= qq|WHERE p.inventory_accno_id > 0|;
3385 if ($p->{searchitems} eq 'service') {
3386 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3388 if ($p->{searchitems} eq 'assembly') {
3389 $query .= qq|WHERE p.assembly = '1'|;
3391 if ($p->{searchitems} eq 'labor') {
3392 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3395 $query .= qq|ORDER BY partsgroup|;
3398 $query = qq|SELECT id, partsgroup FROM partsgroup
3399 ORDER BY partsgroup|;
3402 if ($p->{language_code}) {
3403 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3404 t.description AS translation
3406 JOIN parts p ON (p.partsgroup_id = pg.id)
3407 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3408 ORDER BY translation|;
3409 @values = ($p->{language_code});
3412 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3414 $main::lxdebug->leave_sub();
3417 sub get_pricegroup {
3418 $main::lxdebug->enter_sub();
3420 my ($self, $myconfig, $p) = @_;
3422 my $dbh = $self->get_standard_dbh($myconfig);
3424 my $query = qq|SELECT p.id, p.pricegroup
3427 $query .= qq| ORDER BY pricegroup|;
3430 $query = qq|SELECT id, pricegroup FROM pricegroup
3431 ORDER BY pricegroup|;
3434 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3436 $main::lxdebug->leave_sub();
3440 # usage $form->all_years($myconfig, [$dbh])
3441 # return list of all years where bookings found
3444 $main::lxdebug->enter_sub();
3446 my ($self, $myconfig, $dbh) = @_;
3448 $dbh ||= $self->get_standard_dbh($myconfig);
3451 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3452 (SELECT MAX(transdate) FROM acc_trans)|;
3453 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3455 if ($myconfig->{dateformat} =~ /^yy/) {
3456 ($startdate) = split /\W/, $startdate;
3457 ($enddate) = split /\W/, $enddate;
3459 (@_) = split /\W/, $startdate;
3461 (@_) = split /\W/, $enddate;
3466 $startdate = substr($startdate,0,4);
3467 $enddate = substr($enddate,0,4);
3469 while ($enddate >= $startdate) {
3470 push @all_years, $enddate--;
3475 $main::lxdebug->leave_sub();
3479 $main::lxdebug->enter_sub();
3483 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3485 $main::lxdebug->leave_sub();
3489 $main::lxdebug->enter_sub();
3494 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3496 $main::lxdebug->leave_sub();
3505 SL::Form.pm - main data object.
3509 This is the main data object of Lx-Office.
3510 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3511 Points of interest for a beginner are:
3513 - $form->error - renders a generic error in html. accepts an error message
3514 - $form->get_standard_dbh - returns a database connection for the
3516 =head1 SPECIAL FUNCTIONS
3518 =head2 C<_store_value()>
3520 parses a complex var name, and stores it in the form.
3523 $form->_store_value($key, $value);
3525 keys must start with a string, and can contain various tokens.
3526 supported key structures are:
3529 simple key strings work as expected
3534 separating two keys by a dot (.) will result in a hash lookup for the inner value
3535 this is similar to the behaviour of java and templating mechanisms.
3537 filter.description => $form->{filter}->{description}
3539 3. array+hashref access
3541 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3542 using [+] instead of [] will force a new array index. this is useful for recurring
3543 data structures like part lists. put a [+] into the first varname, and use [] on the
3546 repeating these names in your template:
3549 invoice.items[].parts_id
3553 $form->{invoice}->{items}->[
3567 using brackets at the end of a name will result in a pure array to be created.
3568 note that you mustn't use [+], which is reserved for array+hash access and will
3569 result in undefined behaviour in array context.
3571 filter.status[] => $form->{status}->[ val1, val2, ... ]
3573 =head2 C<update_business> PARAMS
3576 \%config, - config hashref
3577 $business_id, - business id
3578 $dbh - optional database handle
3580 handles business (thats customer/vendor types) sequences.
3582 special behaviour for empty strings in customerinitnumber field:
3583 will in this case not increase the value, and return undef.
3585 =head2 C<redirect_header> $url
3587 Generates a HTTP redirection header for the new C<$url>. Constructs an
3588 absolute URL including scheme, host name and port. If C<$url> is a
3589 relative URL then it is considered relative to Lx-Office base URL.
3591 This function C<die>s if headers have already been created with
3592 C<$::form-E<gt>header>.
3596 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3597 print $::form->redirect_header('http://www.lx-office.org/');
3601 Generates a general purpose http/html header and includes most of the scripts
3602 ans stylesheets needed.
3604 Only one header will be generated. If the method was already called in this
3605 request it will not output anything and return undef. Also if no
3606 HTTP_USER_AGENT is found, no header is generated.
3608 Although header does not accept parameters itself, it will honor special
3609 hashkeys of its Form instance:
3617 If one of these is set, a http-equiv refresh is generated. Missing parameters
3618 default to 3 seconds and the refering url.
3624 If these are arrayrefs the contents will be inlined into the header.
3628 If true, a css snippet will be generated that sets the page in landscape mode.
3632 Used to override the default favicon.
3636 A html page title will be generated from this