1 #====================================================================
4 # Based on SQL-Ledger Version 2.1.9
5 # Web http://www.lx-office.org
7 #=====================================================================
8 # SQL-Ledger Accounting
9 # Copyright (C) 1998-2002
11 # Author: Dieter Simader
12 # Email: dsimader@sql-ledger.org
13 # Web: http://www.sql-ledger.org
15 # Contributors: Thomas Bayen <bayen@gmx.de>
16 # Antti Kaihola <akaihola@siba.fi>
17 # Moritz Bunkus (tex code)
19 # This program is free software; you can redistribute it and/or modify
20 # it under the terms of the GNU General Public License as published by
21 # the Free Software Foundation; either version 2 of the License, or
22 # (at your option) any later version.
24 # This program is distributed in the hope that it will be useful,
25 # but WITHOUT ANY WARRANTY; without even the implied warranty of
26 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
27 # GNU General Public License for more details.
28 # You should have received a copy of the GNU General Public License
29 # along with this program; if not, write to the Free Software
30 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
31 #======================================================================
32 # Utilities for parsing forms
33 # and supporting routines for linking account numbers
34 # used in AR, AP and IS, IR modules
36 #======================================================================
59 use List::Util qw(first max min sum);
60 use List::MoreUtils qw(any apply);
67 disconnect_standard_dbh();
70 sub disconnect_standard_dbh {
71 return unless $standard_dbh;
72 $standard_dbh->disconnect();
77 $main::lxdebug->enter_sub(2);
83 my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
88 $curr = \ $self->{ shift @tokens };
92 my $sep = shift @tokens;
93 my $key = shift @tokens;
95 $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]';
96 $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
97 $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
98 $curr = \ $$curr->{$key}
103 $main::lxdebug->leave_sub(2);
109 $main::lxdebug->enter_sub(2);
114 my @pairs = split(/&/, $input);
117 my ($key, $value) = split(/=/, $_, 2);
118 $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key);
121 $main::lxdebug->leave_sub(2);
124 sub _request_to_hash {
125 $main::lxdebug->enter_sub(2);
130 if (!$ENV{'CONTENT_TYPE'}
131 || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
133 $self->_input_to_hash($input);
135 $main::lxdebug->leave_sub(2);
139 my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
141 my $boundary = '--' . $1;
143 foreach my $line (split m/\n/, $input) {
144 last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
146 if (($line eq $boundary) || ($line eq "$boundary\r")) {
147 ${ $previous } =~ s|\r?\n$|| if $previous;
153 $content_type = "text/plain";
160 next unless $boundary_found;
162 if (!$headers_done) {
163 $line =~ s/[\r\n]*$//;
170 if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
171 if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
173 substr $line, $-[0], $+[0] - $-[0], "";
176 if ($line =~ m|name\s*=\s*"(.*?)"|i) {
178 substr $line, $-[0], $+[0] - $-[0], "";
181 $previous = $self->_store_value($name, '') if ($name);
182 $self->{FILENAME} = $filename if ($filename);
187 if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
194 next unless $previous;
196 ${ $previous } .= "${line}\n";
199 ${ $previous } =~ s|\r?\n$|| if $previous;
201 $main::lxdebug->leave_sub(2);
204 sub _recode_recursively {
205 $main::lxdebug->enter_sub();
206 my ($iconv, $param) = @_;
208 if (any { ref $param eq $_ } qw(Form HASH)) {
209 foreach my $key (keys %{ $param }) {
210 if (!ref $param->{$key}) {
211 # Workaround for a bug: converting $param->{$key} directly
212 # leads to 'undef'. I don't know why. Converting a copy works,
214 $param->{$key} = $iconv->convert("" . $param->{$key});
216 _recode_recursively($iconv, $param->{$key});
220 } elsif (ref $param eq 'ARRAY') {
221 foreach my $idx (0 .. scalar(@{ $param }) - 1) {
222 if (!ref $param->[$idx]) {
223 # Workaround for a bug: converting $param->[$idx] directly
224 # leads to 'undef'. I don't know why. Converting a copy works,
226 $param->[$idx] = $iconv->convert("" . $param->[$idx]);
228 _recode_recursively($iconv, $param->[$idx]);
232 $main::lxdebug->leave_sub();
236 $main::lxdebug->enter_sub();
242 if ($LXDebug::watch_form) {
243 require SL::Watchdog;
244 tie %{ $self }, 'SL::Watchdog';
249 $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
250 $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0];
252 if ($ENV{CONTENT_LENGTH}) {
254 read STDIN, $content, $ENV{CONTENT_LENGTH};
255 $self->_request_to_hash($content);
258 my $db_charset = $main::dbcharset;
259 $db_charset ||= Common::DEFAULT_CHARSET;
261 my $encoding = $self->{INPUT_ENCODING} || $db_charset;
262 delete $self->{INPUT_ENCODING};
264 _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self);
266 #$self->{version} = "2.6.1"; # Old hardcoded but secure style
267 open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file
268 $self->{version} = <VERSION_FILE>;
270 $self->{version} =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code.
272 $main::lxdebug->leave_sub();
277 sub _flatten_variables_rec {
278 $main::lxdebug->enter_sub(2);
287 if ('' eq ref $curr->{$key}) {
288 @result = ({ 'key' => $prefix . $key, 'value' => $curr->{$key} });
290 } elsif ('HASH' eq ref $curr->{$key}) {
291 foreach my $hash_key (sort keys %{ $curr->{$key} }) {
292 push @result, $self->_flatten_variables_rec($curr->{$key}, $prefix . $key . '.', $hash_key);
296 foreach my $idx (0 .. scalar @{ $curr->{$key} } - 1) {
297 my $first_array_entry = 1;
299 foreach my $hash_key (sort keys %{ $curr->{$key}->[$idx] }) {
300 push @result, $self->_flatten_variables_rec($curr->{$key}->[$idx], $prefix . $key . ($first_array_entry ? '[+].' : '[].'), $hash_key);
301 $first_array_entry = 0;
306 $main::lxdebug->leave_sub(2);
311 sub flatten_variables {
312 $main::lxdebug->enter_sub(2);
320 push @variables, $self->_flatten_variables_rec($self, '', $_);
323 $main::lxdebug->leave_sub(2);
328 sub flatten_standard_variables {
329 $main::lxdebug->enter_sub(2);
332 my %skip_keys = map { $_ => 1 } (qw(login password header stylesheet titlebar version), @_);
336 foreach (grep { ! $skip_keys{$_} } keys %{ $self }) {
337 push @variables, $self->_flatten_variables_rec($self, '', $_);
340 $main::lxdebug->leave_sub(2);
346 $main::lxdebug->enter_sub();
352 map { print "$_ = $self->{$_}\n" } (sort keys %{$self});
354 $main::lxdebug->leave_sub();
358 $main::lxdebug->enter_sub(2);
361 my $password = $self->{password};
363 $self->{password} = 'X' x 8;
365 local $Data::Dumper::Sortkeys = 1;
366 my $output = Dumper($self);
368 $self->{password} = $password;
370 $main::lxdebug->leave_sub(2);
376 $main::lxdebug->enter_sub(2);
378 my ($self, $str) = @_;
380 $str = Encode::encode('utf-8-strict', $str) if $::locale->is_utf8;
381 $str =~ s/([^a-zA-Z0-9_.-])/sprintf("%%%02x", ord($1))/ge;
383 $main::lxdebug->leave_sub(2);
389 $main::lxdebug->enter_sub(2);
391 my ($self, $str) = @_;
396 $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
398 $main::lxdebug->leave_sub(2);
404 $main::lxdebug->enter_sub();
405 my ($self, $str) = @_;
407 if ($str && !ref($str)) {
408 $str =~ s/\"/"/g;
411 $main::lxdebug->leave_sub();
417 $main::lxdebug->enter_sub();
418 my ($self, $str) = @_;
420 if ($str && !ref($str)) {
421 $str =~ s/"/\"/g;
424 $main::lxdebug->leave_sub();
430 $main::lxdebug->enter_sub();
434 map({ print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_);
436 for (sort keys %$self) {
437 next if (($_ eq "header") || (ref($self->{$_}) ne ""));
438 print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n");
441 $main::lxdebug->leave_sub();
445 $main::lxdebug->enter_sub();
447 $main::lxdebug->show_backtrace();
449 my ($self, $msg) = @_;
450 if ($ENV{HTTP_USER_AGENT}) {
452 $self->show_generic_error($msg);
455 print STDERR "Error: $msg\n";
459 $main::lxdebug->leave_sub();
463 $main::lxdebug->enter_sub();
465 my ($self, $msg) = @_;
467 if ($ENV{HTTP_USER_AGENT}) {
470 if (!$self->{header}) {
476 <p class="message_ok"><b>$msg</b></p>
478 <script type="text/javascript">
480 // If JavaScript is enabled, the whole thing will be reloaded.
481 // The reason is: When one changes his menu setup (HTML / XUL / CSS ...)
482 // it now loads the correct code into the browser instead of do nothing.
483 setTimeout("top.frames.location.href='login.pl'",500);
492 if ($self->{info_function}) {
493 &{ $self->{info_function} }($msg);
499 $main::lxdebug->leave_sub();
502 # calculates the number of rows in a textarea based on the content and column number
503 # can be capped with maxrows
505 $main::lxdebug->enter_sub();
506 my ($self, $str, $cols, $maxrows, $minrows) = @_;
510 my $rows = sum map { int((length() - 2) / $cols) + 1 } split /\r/, $str;
513 $main::lxdebug->leave_sub();
515 return max(min($rows, $maxrows), $minrows);
519 $main::lxdebug->enter_sub();
521 my ($self, $msg) = @_;
523 $self->error("$msg\n" . $DBI::errstr);
525 $main::lxdebug->leave_sub();
529 $main::lxdebug->enter_sub();
531 my ($self, $name, $msg) = @_;
534 foreach my $part (split m/\./, $name) {
535 if (!$curr->{$part} || ($curr->{$part} =~ /^\s*$/)) {
538 $curr = $curr->{$part};
541 $main::lxdebug->leave_sub();
544 sub _get_request_uri {
547 return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
549 my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http';
550 my $port = $ENV{SERVER_PORT} || '';
551 $port = undef if (($scheme eq 'http' ) && ($port == 80))
552 || (($scheme eq 'https') && ($port == 443));
554 my $uri = URI->new("${scheme}://");
555 $uri->scheme($scheme);
557 $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
558 $uri->path_query($ENV{REQUEST_URI});
564 sub _add_to_request_uri {
567 my $relative_new_path = shift;
568 my $request_uri = shift || $self->_get_request_uri;
569 my $relative_new_uri = URI->new($relative_new_path);
570 my @request_segments = $request_uri->path_segments;
572 my $new_uri = $request_uri->clone;
573 $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments);
578 sub create_http_response {
579 $main::lxdebug->enter_sub();
584 my $cgi = $main::cgi;
585 $cgi ||= CGI->new('');
588 if (defined $main::auth) {
589 my $uri = $self->_get_request_uri;
590 my @segments = $uri->path_segments;
592 $uri->path_segments(@segments);
594 my $session_cookie_value = $main::auth->get_session_id();
596 if ($session_cookie_value) {
597 $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
598 '-value' => $session_cookie_value,
599 '-path' => $uri->path,
600 '-secure' => $ENV{HTTPS});
604 my %cgi_params = ('-type' => $params{content_type});
605 $cgi_params{'-charset'} = $params{charset} if ($params{charset});
606 $cgi_params{'-cookie'} = $session_cookie if ($session_cookie);
608 my $output = $cgi->header(%cgi_params);
610 $main::lxdebug->leave_sub();
617 $::lxdebug->enter_sub;
619 # extra code is currently only used by menuv3 and menuv4 to set their css.
620 # it is strongly deprecated, and will be changed in a future version.
621 my ($self, $extra_code) = @_;
622 my $db_charset = $::dbcharset || Common::DEFAULT_CHARSET;
625 $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
627 $self->{favicon} ||= "favicon.ico";
628 $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title};
631 if ($self->{refresh_url} || $self->{refresh_time}) {
632 my $refresh_time = $self->{refresh_time} || 3;
633 my $refresh_url = $self->{refresh_url} || $ENV{REFERER};
634 push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
637 push @header, "<link rel='stylesheet' href='css/$_' type='text/css' title='Lx-Office stylesheet'>"
638 for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets};
640 push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
641 push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
642 push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
643 '<script type="text/javascript" src="js/common.js"></script>',
644 '<style type="text/css">@import url(js/jscalendar/calendar-win2k-1.css);</style>',
645 '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
646 '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
647 '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
648 '<script type="text/javascript" src="js/part_selection.js"></script>';
649 push @header, $self->{javascript} if $self->{javascript};
650 push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
651 push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
652 push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
653 join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title};
655 # if there is a title, we put some JavaScript in to the page, wich writes a
656 # meaningful title-tag for our frameset.
658 if ($self->{title}) {
660 <script type="text/javascript">
662 // Write a meaningful title-tag for our frameset.
663 top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
669 print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
670 print "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01//EN' 'http://www.w3.org/TR/html4/strict.dtd'>\n"
671 if $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/; # Other browsers may choke on menu scripts with DOCTYPE.
675 <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
676 <title>$self->{titlebar}</title>
678 print " $_\n" for @header;
680 <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css" />
681 <meta name="robots" content="noindex,nofollow" />
682 <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
683 <script type="text/javascript" src="js/tabcontent.js">
685 /***********************************************
686 * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
687 * This notice MUST stay intact for legal use
688 * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
689 ***********************************************/
698 $::lxdebug->leave_sub;
701 sub ajax_response_header {
702 $main::lxdebug->enter_sub();
706 my $db_charset = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
707 my $cgi = $main::cgi || CGI->new('');
708 my $output = $cgi->header('-charset' => $db_charset);
710 $main::lxdebug->leave_sub();
715 sub redirect_header {
719 my $base_uri = $self->_get_request_uri;
720 my $new_uri = URI->new_abs($new_url, $base_uri);
722 die "Headers already sent" if $::self->{header};
725 my $cgi = $main::cgi || CGI->new('');
726 return $cgi->redirect($new_uri);
729 sub set_standard_title {
730 $::lxdebug->enter_sub;
733 $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
734 $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
735 $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
737 $::lxdebug->leave_sub;
740 sub _prepare_html_template {
741 $main::lxdebug->enter_sub();
743 my ($self, $file, $additional_params) = @_;
746 if (!%::myconfig || !$::myconfig{"countrycode"}) {
747 $language = $main::language;
749 $language = $main::myconfig{"countrycode"};
751 $language = "de" unless ($language);
753 if (-f "templates/webpages/${file}.html") {
754 if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
755 my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
756 "Please re-run 'locales.pl' in 'locale/${language}'.";
757 print(qq|<pre>$info</pre>|);
761 $file = "templates/webpages/${file}.html";
764 my $info = "Web page template '${file}' not found.\n";
765 print qq|<pre>$info</pre>|;
769 if ($self->{"DEBUG"}) {
770 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
773 if ($additional_params->{"DEBUG"}) {
774 $additional_params->{"DEBUG"} =
775 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
778 if (%main::myconfig) {
779 $::myconfig{jsc_dateformat} = apply {
783 } $::myconfig{"dateformat"};
784 $additional_params->{"myconfig"} ||= \%::myconfig;
785 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
788 $additional_params->{"conf_dbcharset"} = $::dbcharset;
789 $additional_params->{"conf_webdav"} = $::webdav;
790 $additional_params->{"conf_lizenzen"} = $::lizenzen;
791 $additional_params->{"conf_latex_templates"} = $::latex;
792 $additional_params->{"conf_opendocument_templates"} = $::opendocument_templates;
793 $additional_params->{"conf_vertreter"} = $::vertreter;
794 $additional_params->{"conf_show_best_before"} = $::show_best_before;
795 $additional_params->{"conf_parts_image_css"} = $::parts_image_css;
796 $additional_params->{"conf_parts_listing_images"} = $::parts_listing_images;
797 $additional_params->{"conf_parts_show_image"} = $::parts_show_image;
799 if (%main::debug_options) {
800 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
803 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
804 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
805 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
809 $main::lxdebug->leave_sub();
814 sub parse_html_template {
815 $main::lxdebug->enter_sub();
817 my ($self, $file, $additional_params) = @_;
819 $additional_params ||= { };
821 my $real_file = $self->_prepare_html_template($file, $additional_params);
822 my $template = $self->template || $self->init_template;
824 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
827 $template->process($real_file, $additional_params, \$output) || die $template->error;
829 $main::lxdebug->leave_sub();
837 return if $self->template;
839 return $self->template(Template->new({
844 'PLUGIN_BASE' => 'SL::Template::Plugin',
845 'INCLUDE_PATH' => '.:templates/webpages',
846 'COMPILE_EXT' => '.tcc',
847 'COMPILE_DIR' => $::userspath . '/templates-cache',
853 $self->{template_object} = shift if @_;
854 return $self->{template_object};
857 sub show_generic_error {
858 $main::lxdebug->enter_sub();
860 my ($self, $error, %params) = @_;
863 'title_error' => $params{title},
864 'label_error' => $error,
867 if ($params{action}) {
870 map { delete($self->{$_}); } qw(action);
871 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
873 $add_params->{SHOW_BUTTON} = 1;
874 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
875 $add_params->{VARIABLES} = \@vars;
877 } elsif ($params{back_button}) {
878 $add_params->{SHOW_BACK_BUTTON} = 1;
881 $self->{title} = $params{title} if $params{title};
884 print $self->parse_html_template("generic/error", $add_params);
886 print STDERR "Error: $error\n";
888 $main::lxdebug->leave_sub();
893 sub show_generic_information {
894 $main::lxdebug->enter_sub();
896 my ($self, $text, $title) = @_;
899 'title_information' => $title,
900 'label_information' => $text,
903 $self->{title} = $title if ($title);
906 print $self->parse_html_template("generic/information", $add_params);
908 $main::lxdebug->leave_sub();
913 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
914 # changed it to accept an arbitrary number of triggers - sschoeling
916 $main::lxdebug->enter_sub();
919 my $myconfig = shift;
922 # set dateform for jsscript
925 "dd.mm.yy" => "%d.%m.%Y",
926 "dd-mm-yy" => "%d-%m-%Y",
927 "dd/mm/yy" => "%d/%m/%Y",
928 "mm/dd/yy" => "%m/%d/%Y",
929 "mm-dd-yy" => "%m-%d-%Y",
930 "yyyy-mm-dd" => "%Y-%m-%d",
933 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
934 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
941 inputField : "| . (shift) . qq|",
942 ifFormat :"$ifFormat",
943 align : "| . (shift) . qq|",
944 button : "| . (shift) . qq|"
950 <script type="text/javascript">
951 <!--| . join("", @triggers) . qq|//-->
955 $main::lxdebug->leave_sub();
958 } #end sub write_trigger
961 $main::lxdebug->enter_sub();
963 my ($self, $msg) = @_;
965 if (!$self->{callback}) {
971 # my ($script, $argv) = split(/\?/, $self->{callback}, 2);
972 # $script =~ s|.*/||;
973 # $script =~ s|[^a-zA-Z0-9_\.]||g;
974 # exec("perl", "$script", $argv);
976 print $::form->redirect_header($self->{callback});
978 $main::lxdebug->leave_sub();
981 # sort of columns removed - empty sub
983 $main::lxdebug->enter_sub();
985 my ($self, @columns) = @_;
987 $main::lxdebug->leave_sub();
993 $main::lxdebug->enter_sub(2);
995 my ($self, $myconfig, $amount, $places, $dash) = @_;
1001 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1003 my $neg = ($amount =~ s/^-//);
1004 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1006 if (defined($places) && ($places ne '')) {
1012 my ($actual_places) = ($amount =~ /\.(\d+)/);
1013 $actual_places = length($actual_places);
1014 $places = $actual_places > $places ? $actual_places : $places;
1017 $amount = $self->round_amount($amount, $places);
1020 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1021 my @p = split(/\./, $amount); # split amount at decimal point
1023 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1026 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1029 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1030 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1031 ($neg ? "-$amount" : "$amount" ) ;
1035 $main::lxdebug->leave_sub(2);
1039 sub format_amount_units {
1040 $main::lxdebug->enter_sub();
1045 my $myconfig = \%main::myconfig;
1046 my $amount = $params{amount} * 1;
1047 my $places = $params{places};
1048 my $part_unit_name = $params{part_unit};
1049 my $amount_unit_name = $params{amount_unit};
1050 my $conv_units = $params{conv_units};
1051 my $max_places = $params{max_places};
1053 if (!$part_unit_name) {
1054 $main::lxdebug->leave_sub();
1058 AM->retrieve_all_units();
1059 my $all_units = $main::all_units;
1061 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1062 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1065 if (!scalar @{ $conv_units }) {
1066 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1067 $main::lxdebug->leave_sub();
1071 my $part_unit = $all_units->{$part_unit_name};
1072 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1074 $amount *= $conv_unit->{factor};
1079 foreach my $unit (@$conv_units) {
1080 my $last = $unit->{name} eq $part_unit->{name};
1082 $num = int($amount / $unit->{factor});
1083 $amount -= $num * $unit->{factor};
1086 if ($last ? $amount : $num) {
1087 push @values, { "unit" => $unit->{name},
1088 "amount" => $last ? $amount / $unit->{factor} : $num,
1089 "places" => $last ? $places : 0 };
1096 push @values, { "unit" => $part_unit_name,
1101 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1103 $main::lxdebug->leave_sub();
1109 $main::lxdebug->enter_sub(2);
1114 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1115 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1116 $input =~ s/\#\#/\#/g;
1118 $main::lxdebug->leave_sub(2);
1126 $main::lxdebug->enter_sub(2);
1128 my ($self, $myconfig, $amount) = @_;
1130 if ( ($myconfig->{numberformat} eq '1.000,00')
1131 || ($myconfig->{numberformat} eq '1000,00')) {
1136 if ($myconfig->{numberformat} eq "1'000.00") {
1142 $main::lxdebug->leave_sub(2);
1144 return ($amount * 1);
1148 $main::lxdebug->enter_sub(2);
1150 my ($self, $amount, $places) = @_;
1153 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1155 # Round amounts to eight places before rounding to the requested
1156 # number of places. This gets rid of errors due to internal floating
1157 # point representation.
1158 $amount = $self->round_amount($amount, 8) if $places < 8;
1159 $amount = $amount * (10**($places));
1160 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1162 $main::lxdebug->leave_sub(2);
1164 return $round_amount;
1168 sub parse_template {
1169 $main::lxdebug->enter_sub();
1171 my ($self, $myconfig, $userspath) = @_;
1176 $self->{"cwd"} = getcwd();
1177 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1182 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1183 $template_type = 'OpenDocument';
1184 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1186 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1187 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1188 $template_type = 'LaTeX';
1189 $ext_for_format = 'pdf';
1191 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1192 $template_type = 'HTML';
1193 $ext_for_format = 'html';
1195 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1196 $template_type = 'XML';
1197 $ext_for_format = 'xml';
1199 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1200 $template_type = 'XML';
1202 } elsif ( $self->{"format"} =~ /excel/i ) {
1203 $template_type = 'Excel';
1204 $ext_for_format = 'xls';
1206 } elsif ( defined $self->{'format'}) {
1207 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1209 } elsif ( $self->{'format'} eq '' ) {
1210 $self->error("No Outputformat given: $self->{'format'}");
1212 } else { #Catch the rest
1213 $self->error("Outputformat not defined: $self->{'format'}");
1216 my $template = SL::Template::create(type => $template_type,
1217 file_name => $self->{IN},
1219 myconfig => $myconfig,
1220 userspath => $userspath);
1222 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1223 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1225 if (!$self->{employee_id}) {
1226 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1229 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1231 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1233 # OUT is used for the media, screen, printer, email
1234 # for postscript we store a copy in a temporary file
1236 my $prepend_userspath;
1238 if (!$self->{tmpfile}) {
1239 $self->{tmpfile} = "${fileid}.$self->{IN}";
1240 $prepend_userspath = 1;
1243 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1245 $self->{tmpfile} =~ s|.*/||;
1246 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1247 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1249 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1250 $out = $self->{OUT};
1251 $self->{OUT} = ">$self->{tmpfile}";
1257 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1258 $result = $template->parse(*OUT);
1263 $result = $template->parse(*STDOUT);
1268 $self->error("$self->{IN} : " . $template->get_error());
1271 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1273 if ($self->{media} eq 'email') {
1275 my $mail = new Mailer;
1277 map { $mail->{$_} = $self->{$_} }
1278 qw(cc bcc subject message version format);
1279 $mail->{charset} = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
1280 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1281 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1282 $mail->{fileid} = "$fileid.";
1283 $myconfig->{signature} =~ s/\r//g;
1285 # if we send html or plain text inline
1286 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1287 $mail->{contenttype} = "text/html";
1289 $mail->{message} =~ s/\r//g;
1290 $mail->{message} =~ s/\n/<br>\n/g;
1291 $myconfig->{signature} =~ s/\n/<br>\n/g;
1292 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1294 open(IN, $self->{tmpfile})
1295 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1297 $mail->{message} .= $_;
1304 if (!$self->{"do_not_attach"}) {
1305 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1306 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1307 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1308 "name" => $attachment_name }];
1311 $mail->{message} =~ s/\r//g;
1312 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1316 my $err = $mail->send();
1317 $self->error($self->cleanup . "$err") if ($err);
1321 $self->{OUT} = $out;
1323 my $numbytes = (-s $self->{tmpfile});
1324 open(IN, $self->{tmpfile})
1325 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1327 $self->{copies} = 1 unless $self->{media} eq 'printer';
1329 chdir("$self->{cwd}");
1330 #print(STDERR "Kopien $self->{copies}\n");
1331 #print(STDERR "OUT $self->{OUT}\n");
1332 for my $i (1 .. $self->{copies}) {
1334 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1335 print OUT while <IN>;
1340 $self->{attachment_filename} = ($self->{attachment_filename})
1341 ? $self->{attachment_filename}
1342 : $self->generate_attachment_filename();
1344 # launch application
1345 print qq|Content-Type: | . $template->get_mime_type() . qq|
1346 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1347 Content-Length: $numbytes
1351 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1362 chdir("$self->{cwd}");
1363 $main::lxdebug->leave_sub();
1366 sub get_formname_translation {
1367 $main::lxdebug->enter_sub();
1368 my ($self, $formname) = @_;
1370 $formname ||= $self->{formname};
1372 my %formname_translations = (
1373 bin_list => $main::locale->text('Bin List'),
1374 credit_note => $main::locale->text('Credit Note'),
1375 invoice => $main::locale->text('Invoice'),
1376 pick_list => $main::locale->text('Pick List'),
1377 proforma => $main::locale->text('Proforma Invoice'),
1378 purchase_order => $main::locale->text('Purchase Order'),
1379 request_quotation => $main::locale->text('RFQ'),
1380 sales_order => $main::locale->text('Confirmation'),
1381 sales_quotation => $main::locale->text('Quotation'),
1382 storno_invoice => $main::locale->text('Storno Invoice'),
1383 sales_delivery_order => $main::locale->text('Delivery Order'),
1384 purchase_delivery_order => $main::locale->text('Delivery Order'),
1385 dunning => $main::locale->text('Dunning'),
1388 $main::lxdebug->leave_sub();
1389 return $formname_translations{$formname}
1392 sub get_number_prefix_for_type {
1393 $main::lxdebug->enter_sub();
1397 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1398 : ($self->{type} =~ /_quotation$/) ? 'quo'
1399 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1402 $main::lxdebug->leave_sub();
1406 sub get_extension_for_format {
1407 $main::lxdebug->enter_sub();
1410 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1411 : $self->{format} =~ /postscript/i ? ".ps"
1412 : $self->{format} =~ /opendocument/i ? ".odt"
1413 : $self->{format} =~ /excel/i ? ".xls"
1414 : $self->{format} =~ /html/i ? ".html"
1417 $main::lxdebug->leave_sub();
1421 sub generate_attachment_filename {
1422 $main::lxdebug->enter_sub();
1425 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1426 my $prefix = $self->get_number_prefix_for_type();
1428 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1429 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1431 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1432 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1435 $attachment_filename = "";
1438 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1439 $attachment_filename =~ s|[\s/\\]+|_|g;
1441 $main::lxdebug->leave_sub();
1442 return $attachment_filename;
1445 sub generate_email_subject {
1446 $main::lxdebug->enter_sub();
1449 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1450 my $prefix = $self->get_number_prefix_for_type();
1452 if ($subject && $self->{"${prefix}number"}) {
1453 $subject .= " " . $self->{"${prefix}number"}
1456 $main::lxdebug->leave_sub();
1461 $main::lxdebug->enter_sub();
1465 chdir("$self->{tmpdir}");
1468 if (-f "$self->{tmpfile}.err") {
1469 open(FH, "$self->{tmpfile}.err");
1474 if ($self->{tmpfile} && ! $::keep_temp_files) {
1475 $self->{tmpfile} =~ s|.*/||g;
1477 $self->{tmpfile} =~ s/\.\w+$//g;
1478 my $tmpfile = $self->{tmpfile};
1479 unlink(<$tmpfile.*>);
1482 chdir("$self->{cwd}");
1484 $main::lxdebug->leave_sub();
1490 $main::lxdebug->enter_sub();
1492 my ($self, $date, $myconfig) = @_;
1495 if ($date && $date =~ /\D/) {
1497 if ($myconfig->{dateformat} =~ /^yy/) {
1498 ($yy, $mm, $dd) = split /\D/, $date;
1500 if ($myconfig->{dateformat} =~ /^mm/) {
1501 ($mm, $dd, $yy) = split /\D/, $date;
1503 if ($myconfig->{dateformat} =~ /^dd/) {
1504 ($dd, $mm, $yy) = split /\D/, $date;
1509 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1510 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1512 $dd = "0$dd" if ($dd < 10);
1513 $mm = "0$mm" if ($mm < 10);
1515 $date = "$yy$mm$dd";
1518 $main::lxdebug->leave_sub();
1523 # Database routines used throughout
1525 sub _dbconnect_options {
1527 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1534 $main::lxdebug->enter_sub(2);
1536 my ($self, $myconfig) = @_;
1538 # connect to database
1539 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1543 if ($myconfig->{dboptions}) {
1544 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1547 $main::lxdebug->leave_sub(2);
1552 sub dbconnect_noauto {
1553 $main::lxdebug->enter_sub();
1555 my ($self, $myconfig) = @_;
1557 # connect to database
1558 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1562 if ($myconfig->{dboptions}) {
1563 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1566 $main::lxdebug->leave_sub();
1571 sub get_standard_dbh {
1572 $main::lxdebug->enter_sub(2);
1575 my $myconfig = shift || \%::myconfig;
1577 if ($standard_dbh && !$standard_dbh->{Active}) {
1578 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1579 undef $standard_dbh;
1582 $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1584 $main::lxdebug->leave_sub(2);
1586 return $standard_dbh;
1590 $main::lxdebug->enter_sub();
1592 my ($self, $date, $myconfig) = @_;
1593 my $dbh = $self->dbconnect($myconfig);
1595 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1596 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1597 my ($closed) = $sth->fetchrow_array;
1599 $main::lxdebug->leave_sub();
1604 sub update_balance {
1605 $main::lxdebug->enter_sub();
1607 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1609 # if we have a value, go do it
1612 # retrieve balance from table
1613 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1614 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1615 my ($balance) = $sth->fetchrow_array;
1621 $query = "UPDATE $table SET $field = $balance WHERE $where";
1622 do_query($self, $dbh, $query, @values);
1624 $main::lxdebug->leave_sub();
1627 sub update_exchangerate {
1628 $main::lxdebug->enter_sub();
1630 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1632 # some sanity check for currency
1634 $main::lxdebug->leave_sub();
1637 $query = qq|SELECT curr FROM defaults|;
1639 my ($currency) = selectrow_query($self, $dbh, $query);
1640 my ($defaultcurrency) = split m/:/, $currency;
1643 if ($curr eq $defaultcurrency) {
1644 $main::lxdebug->leave_sub();
1648 $query = qq|SELECT e.curr FROM exchangerate e
1649 WHERE e.curr = ? AND e.transdate = ?
1651 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1660 $buy = conv_i($buy, "NULL");
1661 $sell = conv_i($sell, "NULL");
1664 if ($buy != 0 && $sell != 0) {
1665 $set = "buy = $buy, sell = $sell";
1666 } elsif ($buy != 0) {
1667 $set = "buy = $buy";
1668 } elsif ($sell != 0) {
1669 $set = "sell = $sell";
1672 if ($sth->fetchrow_array) {
1673 $query = qq|UPDATE exchangerate
1679 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1680 VALUES (?, $buy, $sell, ?)|;
1683 do_query($self, $dbh, $query, $curr, $transdate);
1685 $main::lxdebug->leave_sub();
1688 sub save_exchangerate {
1689 $main::lxdebug->enter_sub();
1691 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1693 my $dbh = $self->dbconnect($myconfig);
1697 $buy = $rate if $fld eq 'buy';
1698 $sell = $rate if $fld eq 'sell';
1701 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1706 $main::lxdebug->leave_sub();
1709 sub get_exchangerate {
1710 $main::lxdebug->enter_sub();
1712 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1715 unless ($transdate) {
1716 $main::lxdebug->leave_sub();
1720 $query = qq|SELECT curr FROM defaults|;
1722 my ($currency) = selectrow_query($self, $dbh, $query);
1723 my ($defaultcurrency) = split m/:/, $currency;
1725 if ($currency eq $defaultcurrency) {
1726 $main::lxdebug->leave_sub();
1730 $query = qq|SELECT e.$fld FROM exchangerate e
1731 WHERE e.curr = ? AND e.transdate = ?|;
1732 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1736 $main::lxdebug->leave_sub();
1738 return $exchangerate;
1741 sub check_exchangerate {
1742 $main::lxdebug->enter_sub();
1744 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1746 if ($fld !~/^buy|sell$/) {
1747 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1750 unless ($transdate) {
1751 $main::lxdebug->leave_sub();
1755 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1757 if ($currency eq $defaultcurrency) {
1758 $main::lxdebug->leave_sub();
1762 my $dbh = $self->get_standard_dbh($myconfig);
1763 my $query = qq|SELECT e.$fld FROM exchangerate e
1764 WHERE e.curr = ? AND e.transdate = ?|;
1766 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1768 $main::lxdebug->leave_sub();
1770 return $exchangerate;
1773 sub get_all_currencies {
1774 $main::lxdebug->enter_sub();
1777 my $myconfig = shift || \%::myconfig;
1778 my $dbh = $self->get_standard_dbh($myconfig);
1780 my $query = qq|SELECT curr FROM defaults|;
1782 my ($curr) = selectrow_query($self, $dbh, $query);
1783 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1785 $main::lxdebug->leave_sub();
1790 sub get_default_currency {
1791 $main::lxdebug->enter_sub();
1793 my ($self, $myconfig) = @_;
1794 my @currencies = $self->get_all_currencies($myconfig);
1796 $main::lxdebug->leave_sub();
1798 return $currencies[0];
1801 sub set_payment_options {
1802 $main::lxdebug->enter_sub();
1804 my ($self, $myconfig, $transdate) = @_;
1806 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1808 my $dbh = $self->get_standard_dbh($myconfig);
1811 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1812 qq|FROM payment_terms p | .
1815 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1816 $self->{payment_terms}) =
1817 selectrow_query($self, $dbh, $query, $self->{payment_id});
1819 if ($transdate eq "") {
1820 if ($self->{invdate}) {
1821 $transdate = $self->{invdate};
1823 $transdate = $self->{transdate};
1828 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1829 qq|FROM payment_terms|;
1830 ($self->{netto_date}, $self->{skonto_date}) =
1831 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1833 my ($invtotal, $total);
1834 my (%amounts, %formatted_amounts);
1836 if ($self->{type} =~ /_order$/) {
1837 $amounts{invtotal} = $self->{ordtotal};
1838 $amounts{total} = $self->{ordtotal};
1840 } elsif ($self->{type} =~ /_quotation$/) {
1841 $amounts{invtotal} = $self->{quototal};
1842 $amounts{total} = $self->{quototal};
1845 $amounts{invtotal} = $self->{invtotal};
1846 $amounts{total} = $self->{total};
1848 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1850 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1852 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1853 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1854 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1856 foreach (keys %amounts) {
1857 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1858 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1861 if ($self->{"language_id"}) {
1863 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1864 qq|FROM translation_payment_terms t | .
1865 qq|LEFT JOIN language l ON t.language_id = l.id | .
1866 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1867 my ($description_long, $output_numberformat, $output_dateformat,
1868 $output_longdates) =
1869 selectrow_query($self, $dbh, $query,
1870 $self->{"language_id"}, $self->{"payment_id"});
1872 $self->{payment_terms} = $description_long if ($description_long);
1874 if ($output_dateformat) {
1875 foreach my $key (qw(netto_date skonto_date)) {
1877 $main::locale->reformat_date($myconfig, $self->{$key},
1883 if ($output_numberformat &&
1884 ($output_numberformat ne $myconfig->{"numberformat"})) {
1885 my $saved_numberformat = $myconfig->{"numberformat"};
1886 $myconfig->{"numberformat"} = $output_numberformat;
1887 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1888 $myconfig->{"numberformat"} = $saved_numberformat;
1892 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1893 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1894 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1895 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1896 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1897 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1898 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1900 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1902 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1904 $main::lxdebug->leave_sub();
1908 sub get_template_language {
1909 $main::lxdebug->enter_sub();
1911 my ($self, $myconfig) = @_;
1913 my $template_code = "";
1915 if ($self->{language_id}) {
1916 my $dbh = $self->get_standard_dbh($myconfig);
1917 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1918 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1921 $main::lxdebug->leave_sub();
1923 return $template_code;
1926 sub get_printer_code {
1927 $main::lxdebug->enter_sub();
1929 my ($self, $myconfig) = @_;
1931 my $template_code = "";
1933 if ($self->{printer_id}) {
1934 my $dbh = $self->get_standard_dbh($myconfig);
1935 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1936 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1939 $main::lxdebug->leave_sub();
1941 return $template_code;
1945 $main::lxdebug->enter_sub();
1947 my ($self, $myconfig) = @_;
1949 my $template_code = "";
1951 if ($self->{shipto_id}) {
1952 my $dbh = $self->get_standard_dbh($myconfig);
1953 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1954 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1955 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1958 $main::lxdebug->leave_sub();
1962 $main::lxdebug->enter_sub();
1964 my ($self, $dbh, $id, $module) = @_;
1969 foreach my $item (qw(name department_1 department_2 street zipcode city country
1970 contact cp_gender phone fax email)) {
1971 if ($self->{"shipto$item"}) {
1972 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1974 push(@values, $self->{"shipto${item}"});
1978 if ($self->{shipto_id}) {
1979 my $query = qq|UPDATE shipto set
1981 shiptodepartment_1 = ?,
1982 shiptodepartment_2 = ?,
1988 shiptocp_gender = ?,
1992 WHERE shipto_id = ?|;
1993 do_query($self, $dbh, $query, @values, $self->{shipto_id});
1995 my $query = qq|SELECT * FROM shipto
1996 WHERE shiptoname = ? AND
1997 shiptodepartment_1 = ? AND
1998 shiptodepartment_2 = ? AND
1999 shiptostreet = ? AND
2000 shiptozipcode = ? AND
2002 shiptocountry = ? AND
2003 shiptocontact = ? AND
2004 shiptocp_gender = ? AND
2010 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2013 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2014 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2015 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2016 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2017 do_query($self, $dbh, $query, $id, @values, $module);
2022 $main::lxdebug->leave_sub();
2026 $main::lxdebug->enter_sub();
2028 my ($self, $dbh) = @_;
2030 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2032 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2033 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2034 $self->{"employee_id"} *= 1;
2036 $main::lxdebug->leave_sub();
2039 sub get_employee_data {
2040 $main::lxdebug->enter_sub();
2045 Common::check_params(\%params, qw(prefix));
2046 Common::check_params_x(\%params, qw(id));
2049 $main::lxdebug->leave_sub();
2053 my $myconfig = \%main::myconfig;
2054 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2056 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2059 my $user = User->new($login);
2060 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2062 $self->{$params{prefix} . '_login'} = $login;
2063 $self->{$params{prefix} . '_name'} ||= $login;
2066 $main::lxdebug->leave_sub();
2070 $main::lxdebug->enter_sub();
2072 my ($self, $myconfig, $reference_date) = @_;
2074 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2076 my $dbh = $self->get_standard_dbh($myconfig);
2077 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2078 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2080 $main::lxdebug->leave_sub();
2086 $main::lxdebug->enter_sub();
2088 my ($self, $dbh, $id, $key) = @_;
2090 $key = "all_contacts" unless ($key);
2094 $main::lxdebug->leave_sub();
2099 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2100 qq|FROM contacts | .
2101 qq|WHERE cp_cv_id = ? | .
2102 qq|ORDER BY lower(cp_name)|;
2104 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2106 $main::lxdebug->leave_sub();
2110 $main::lxdebug->enter_sub();
2112 my ($self, $dbh, $key) = @_;
2114 my ($all, $old_id, $where, @values);
2116 if (ref($key) eq "HASH") {
2119 $key = "ALL_PROJECTS";
2121 foreach my $p (keys(%{$params})) {
2123 $all = $params->{$p};
2124 } elsif ($p eq "old_id") {
2125 $old_id = $params->{$p};
2126 } elsif ($p eq "key") {
2127 $key = $params->{$p};
2133 $where = "WHERE active ";
2135 if (ref($old_id) eq "ARRAY") {
2136 my @ids = grep({ $_ } @{$old_id});
2138 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2139 push(@values, @ids);
2142 $where .= " OR (id = ?) ";
2143 push(@values, $old_id);
2149 qq|SELECT id, projectnumber, description, active | .
2152 qq|ORDER BY lower(projectnumber)|;
2154 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2156 $main::lxdebug->leave_sub();
2160 $main::lxdebug->enter_sub();
2162 my ($self, $dbh, $vc_id, $key) = @_;
2164 $key = "all_shipto" unless ($key);
2167 # get shipping addresses
2168 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2170 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2176 $main::lxdebug->leave_sub();
2180 $main::lxdebug->enter_sub();
2182 my ($self, $dbh, $key) = @_;
2184 $key = "all_printers" unless ($key);
2186 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2188 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2190 $main::lxdebug->leave_sub();
2194 $main::lxdebug->enter_sub();
2196 my ($self, $dbh, $params) = @_;
2199 $key = $params->{key};
2200 $key = "all_charts" unless ($key);
2202 my $transdate = quote_db_date($params->{transdate});
2205 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2207 qq|LEFT JOIN taxkeys tk ON | .
2208 qq|(tk.id = (SELECT id FROM taxkeys | .
2209 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2210 qq| ORDER BY startdate DESC LIMIT 1)) | .
2211 qq|ORDER BY c.accno|;
2213 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2215 $main::lxdebug->leave_sub();
2218 sub _get_taxcharts {
2219 $main::lxdebug->enter_sub();
2221 my ($self, $dbh, $params) = @_;
2223 my $key = "all_taxcharts";
2226 if (ref $params eq 'HASH') {
2227 $key = $params->{key} if ($params->{key});
2228 if ($params->{module} eq 'AR') {
2229 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2231 } elsif ($params->{module} eq 'AP') {
2232 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2239 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2241 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2243 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2245 $main::lxdebug->leave_sub();
2249 $main::lxdebug->enter_sub();
2251 my ($self, $dbh, $key) = @_;
2253 $key = "all_taxzones" unless ($key);
2255 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2257 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2259 $main::lxdebug->leave_sub();
2262 sub _get_employees {
2263 $main::lxdebug->enter_sub();
2265 my ($self, $dbh, $default_key, $key) = @_;
2267 $key = $default_key unless ($key);
2268 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2270 $main::lxdebug->leave_sub();
2273 sub _get_business_types {
2274 $main::lxdebug->enter_sub();
2276 my ($self, $dbh, $key) = @_;
2278 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2279 $options->{key} ||= "all_business_types";
2282 if (exists $options->{salesman}) {
2283 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2286 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2288 $main::lxdebug->leave_sub();
2291 sub _get_languages {
2292 $main::lxdebug->enter_sub();
2294 my ($self, $dbh, $key) = @_;
2296 $key = "all_languages" unless ($key);
2298 my $query = qq|SELECT * FROM language ORDER BY id|;
2300 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2302 $main::lxdebug->leave_sub();
2305 sub _get_dunning_configs {
2306 $main::lxdebug->enter_sub();
2308 my ($self, $dbh, $key) = @_;
2310 $key = "all_dunning_configs" unless ($key);
2312 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2314 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2316 $main::lxdebug->leave_sub();
2319 sub _get_currencies {
2320 $main::lxdebug->enter_sub();
2322 my ($self, $dbh, $key) = @_;
2324 $key = "all_currencies" unless ($key);
2326 my $query = qq|SELECT curr AS currency FROM defaults|;
2328 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2330 $main::lxdebug->leave_sub();
2334 $main::lxdebug->enter_sub();
2336 my ($self, $dbh, $key) = @_;
2338 $key = "all_payments" unless ($key);
2340 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2342 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2344 $main::lxdebug->leave_sub();
2347 sub _get_customers {
2348 $main::lxdebug->enter_sub();
2350 my ($self, $dbh, $key) = @_;
2352 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2353 $options->{key} ||= "all_customers";
2354 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2357 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2358 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2359 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2361 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2362 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2364 $main::lxdebug->leave_sub();
2368 $main::lxdebug->enter_sub();
2370 my ($self, $dbh, $key) = @_;
2372 $key = "all_vendors" unless ($key);
2374 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2376 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2378 $main::lxdebug->leave_sub();
2381 sub _get_departments {
2382 $main::lxdebug->enter_sub();
2384 my ($self, $dbh, $key) = @_;
2386 $key = "all_departments" unless ($key);
2388 my $query = qq|SELECT * FROM department ORDER BY description|;
2390 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2392 $main::lxdebug->leave_sub();
2395 sub _get_warehouses {
2396 $main::lxdebug->enter_sub();
2398 my ($self, $dbh, $param) = @_;
2400 my ($key, $bins_key);
2402 if ('' eq ref $param) {
2406 $key = $param->{key};
2407 $bins_key = $param->{bins};
2410 my $query = qq|SELECT w.* FROM warehouse w
2411 WHERE (NOT w.invalid) AND
2412 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2413 ORDER BY w.sortkey|;
2415 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2418 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2419 my $sth = prepare_query($self, $dbh, $query);
2421 foreach my $warehouse (@{ $self->{$key} }) {
2422 do_statement($self, $sth, $query, $warehouse->{id});
2423 $warehouse->{$bins_key} = [];
2425 while (my $ref = $sth->fetchrow_hashref()) {
2426 push @{ $warehouse->{$bins_key} }, $ref;
2432 $main::lxdebug->leave_sub();
2436 $main::lxdebug->enter_sub();
2438 my ($self, $dbh, $table, $key, $sortkey) = @_;
2440 my $query = qq|SELECT * FROM $table|;
2441 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2443 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2445 $main::lxdebug->leave_sub();
2449 # $main::lxdebug->enter_sub();
2451 # my ($self, $dbh, $key) = @_;
2453 # $key ||= "all_groups";
2455 # my $groups = $main::auth->read_groups();
2457 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2459 # $main::lxdebug->leave_sub();
2463 $main::lxdebug->enter_sub();
2468 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2469 my ($sth, $query, $ref);
2471 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2472 my $vc_id = $self->{"${vc}_id"};
2474 if ($params{"contacts"}) {
2475 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2478 if ($params{"shipto"}) {
2479 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2482 if ($params{"projects"} || $params{"all_projects"}) {
2483 $self->_get_projects($dbh, $params{"all_projects"} ?
2484 $params{"all_projects"} : $params{"projects"},
2485 $params{"all_projects"} ? 1 : 0);
2488 if ($params{"printers"}) {
2489 $self->_get_printers($dbh, $params{"printers"});
2492 if ($params{"languages"}) {
2493 $self->_get_languages($dbh, $params{"languages"});
2496 if ($params{"charts"}) {
2497 $self->_get_charts($dbh, $params{"charts"});
2500 if ($params{"taxcharts"}) {
2501 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2504 if ($params{"taxzones"}) {
2505 $self->_get_taxzones($dbh, $params{"taxzones"});
2508 if ($params{"employees"}) {
2509 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2512 if ($params{"salesmen"}) {
2513 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2516 if ($params{"business_types"}) {
2517 $self->_get_business_types($dbh, $params{"business_types"});
2520 if ($params{"dunning_configs"}) {
2521 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2524 if($params{"currencies"}) {
2525 $self->_get_currencies($dbh, $params{"currencies"});
2528 if($params{"customers"}) {
2529 $self->_get_customers($dbh, $params{"customers"});
2532 if($params{"vendors"}) {
2533 if (ref $params{"vendors"} eq 'HASH') {
2534 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2536 $self->_get_vendors($dbh, $params{"vendors"});
2540 if($params{"payments"}) {
2541 $self->_get_payments($dbh, $params{"payments"});
2544 if($params{"departments"}) {
2545 $self->_get_departments($dbh, $params{"departments"});
2548 if ($params{price_factors}) {
2549 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2552 if ($params{warehouses}) {
2553 $self->_get_warehouses($dbh, $params{warehouses});
2556 # if ($params{groups}) {
2557 # $self->_get_groups($dbh, $params{groups});
2560 if ($params{partsgroup}) {
2561 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2564 $main::lxdebug->leave_sub();
2567 # this sub gets the id and name from $table
2569 $main::lxdebug->enter_sub();
2571 my ($self, $myconfig, $table) = @_;
2573 # connect to database
2574 my $dbh = $self->get_standard_dbh($myconfig);
2576 $table = $table eq "customer" ? "customer" : "vendor";
2577 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2579 my ($query, @values);
2581 if (!$self->{openinvoices}) {
2583 if ($self->{customernumber} ne "") {
2584 $where = qq|(vc.customernumber ILIKE ?)|;
2585 push(@values, '%' . $self->{customernumber} . '%');
2587 $where = qq|(vc.name ILIKE ?)|;
2588 push(@values, '%' . $self->{$table} . '%');
2592 qq~SELECT vc.id, vc.name,
2593 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2595 WHERE $where AND (NOT vc.obsolete)
2599 qq~SELECT DISTINCT vc.id, vc.name,
2600 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2602 JOIN $table vc ON (a.${table}_id = vc.id)
2603 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2605 push(@values, '%' . $self->{$table} . '%');
2608 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2610 $main::lxdebug->leave_sub();
2612 return scalar(@{ $self->{name_list} });
2615 # the selection sub is used in the AR, AP, IS, IR and OE module
2618 $main::lxdebug->enter_sub();
2620 my ($self, $myconfig, $table, $module) = @_;
2623 my $dbh = $self->get_standard_dbh;
2625 $table = $table eq "customer" ? "customer" : "vendor";
2627 my $query = qq|SELECT count(*) FROM $table|;
2628 my ($count) = selectrow_query($self, $dbh, $query);
2630 # build selection list
2631 if ($count <= $myconfig->{vclimit}) {
2632 $query = qq|SELECT id, name, salesman_id
2633 FROM $table WHERE NOT obsolete
2635 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2639 $self->get_employee($dbh);
2641 # setup sales contacts
2642 $query = qq|SELECT e.id, e.name
2644 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2645 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2648 push(@{ $self->{all_employees} },
2649 { id => $self->{employee_id},
2650 name => $self->{employee} });
2652 # sort the whole thing
2653 @{ $self->{all_employees} } =
2654 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2656 if ($module eq 'AR') {
2658 # prepare query for departments
2659 $query = qq|SELECT id, description
2662 ORDER BY description|;
2665 $query = qq|SELECT id, description
2667 ORDER BY description|;
2670 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2673 $query = qq|SELECT id, description
2677 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2680 $query = qq|SELECT printer_description, id
2682 ORDER BY printer_description|;
2684 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2687 $query = qq|SELECT id, description
2691 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2693 $main::lxdebug->leave_sub();
2696 sub language_payment {
2697 $main::lxdebug->enter_sub();
2699 my ($self, $myconfig) = @_;
2701 my $dbh = $self->get_standard_dbh($myconfig);
2703 my $query = qq|SELECT id, description
2707 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2710 $query = qq|SELECT printer_description, id
2712 ORDER BY printer_description|;
2714 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2717 $query = qq|SELECT id, description
2721 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2723 # get buchungsgruppen
2724 $query = qq|SELECT id, description
2725 FROM buchungsgruppen|;
2727 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2729 $main::lxdebug->leave_sub();
2732 # this is only used for reports
2733 sub all_departments {
2734 $main::lxdebug->enter_sub();
2736 my ($self, $myconfig, $table) = @_;
2738 my $dbh = $self->get_standard_dbh($myconfig);
2741 if ($table eq 'customer') {
2742 $where = "WHERE role = 'P' ";
2745 my $query = qq|SELECT id, description
2748 ORDER BY description|;
2749 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2751 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2753 $main::lxdebug->leave_sub();
2757 $main::lxdebug->enter_sub();
2759 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2762 if ($table eq "customer") {
2771 $self->all_vc($myconfig, $table, $module);
2773 # get last customers or vendors
2774 my ($query, $sth, $ref);
2776 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2781 my $transdate = "current_date";
2782 if ($self->{transdate}) {
2783 $transdate = $dbh->quote($self->{transdate});
2786 # now get the account numbers
2787 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2788 FROM chart c, taxkeys tk
2789 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2790 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2793 $sth = $dbh->prepare($query);
2795 do_statement($self, $sth, $query, '%' . $module . '%');
2797 $self->{accounts} = "";
2798 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2800 foreach my $key (split(/:/, $ref->{link})) {
2801 if ($key =~ /\Q$module\E/) {
2803 # cross reference for keys
2804 $xkeyref{ $ref->{accno} } = $key;
2806 push @{ $self->{"${module}_links"}{$key} },
2807 { accno => $ref->{accno},
2808 description => $ref->{description},
2809 taxkey => $ref->{taxkey_id},
2810 tax_id => $ref->{tax_id} };
2812 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2818 # get taxkeys and description
2819 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2820 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2822 if (($module eq "AP") || ($module eq "AR")) {
2823 # get tax rates and description
2824 $query = qq|SELECT * FROM tax|;
2825 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2831 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2832 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2833 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2834 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2836 d.description AS department,
2839 JOIN $table c ON (a.${table}_id = c.id)
2840 LEFT JOIN employee e ON (e.id = a.employee_id)
2841 LEFT JOIN department d ON (d.id = a.department_id)
2843 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2845 foreach my $key (keys %$ref) {
2846 $self->{$key} = $ref->{$key};
2849 my $transdate = "current_date";
2850 if ($self->{transdate}) {
2851 $transdate = $dbh->quote($self->{transdate});
2854 # now get the account numbers
2855 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2857 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2859 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2860 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2863 $sth = $dbh->prepare($query);
2864 do_statement($self, $sth, $query, "%$module%");
2866 $self->{accounts} = "";
2867 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2869 foreach my $key (split(/:/, $ref->{link})) {
2870 if ($key =~ /\Q$module\E/) {
2872 # cross reference for keys
2873 $xkeyref{ $ref->{accno} } = $key;
2875 push @{ $self->{"${module}_links"}{$key} },
2876 { accno => $ref->{accno},
2877 description => $ref->{description},
2878 taxkey => $ref->{taxkey_id},
2879 tax_id => $ref->{tax_id} };
2881 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2887 # get amounts from individual entries
2890 c.accno, c.description,
2891 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2895 LEFT JOIN chart c ON (c.id = a.chart_id)
2896 LEFT JOIN project p ON (p.id = a.project_id)
2897 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2898 WHERE (tk.taxkey_id=a.taxkey) AND
2899 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2900 THEN tk.chart_id = a.chart_id
2903 OR (c.link='%tax%')) AND
2904 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2905 WHERE a.trans_id = ?
2906 AND a.fx_transaction = '0'
2907 ORDER BY a.acc_trans_id, a.transdate|;
2908 $sth = $dbh->prepare($query);
2909 do_statement($self, $sth, $query, $self->{id});
2911 # get exchangerate for currency
2912 $self->{exchangerate} =
2913 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2916 # store amounts in {acc_trans}{$key} for multiple accounts
2917 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2918 $ref->{exchangerate} =
2919 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2920 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2923 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2924 $ref->{amount} *= -1;
2926 $ref->{index} = $index;
2928 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2934 d.curr AS currencies, d.closedto, d.revtrans,
2935 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2936 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2938 $ref = selectfirst_hashref_query($self, $dbh, $query);
2939 map { $self->{$_} = $ref->{$_} } keys %$ref;
2946 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2947 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2948 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2950 $ref = selectfirst_hashref_query($self, $dbh, $query);
2951 map { $self->{$_} = $ref->{$_} } keys %$ref;
2953 if ($self->{"$self->{vc}_id"}) {
2955 # only setup currency
2956 ($self->{currency}) = split(/:/, $self->{currencies});
2960 $self->lastname_used($dbh, $myconfig, $table, $module);
2962 # get exchangerate for currency
2963 $self->{exchangerate} =
2964 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2970 $main::lxdebug->leave_sub();
2974 $main::lxdebug->enter_sub();
2976 my ($self, $dbh, $myconfig, $table, $module) = @_;
2980 $table = $table eq "customer" ? "customer" : "vendor";
2981 my %column_map = ("a.curr" => "currency",
2982 "a.${table}_id" => "${table}_id",
2983 "a.department_id" => "department_id",
2984 "d.description" => "department",
2985 "ct.name" => $table,
2986 "current_date + ct.terms" => "duedate",
2989 if ($self->{type} =~ /delivery_order/) {
2990 $arap = 'delivery_orders';
2991 delete $column_map{"a.curr"};
2993 } elsif ($self->{type} =~ /_order/) {
2995 $where = "quotation = '0'";
2997 } elsif ($self->{type} =~ /_quotation/) {
2999 $where = "quotation = '1'";
3001 } elsif ($table eq 'customer') {
3009 $where = "($where) AND" if ($where);
3010 my $query = qq|SELECT MAX(id) FROM $arap
3011 WHERE $where ${table}_id > 0|;
3012 my ($trans_id) = selectrow_query($self, $dbh, $query);
3015 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3016 $query = qq|SELECT $column_spec
3018 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3019 LEFT JOIN department d ON (a.department_id = d.id)
3021 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3023 map { $self->{$_} = $ref->{$_} } values %column_map;
3025 $main::lxdebug->leave_sub();
3029 $main::lxdebug->enter_sub();
3032 my $myconfig = shift || \%::myconfig;
3033 my ($thisdate, $days) = @_;
3035 my $dbh = $self->get_standard_dbh($myconfig);
3040 my $dateformat = $myconfig->{dateformat};
3041 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3042 $thisdate = $dbh->quote($thisdate);
3043 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3045 $query = qq|SELECT current_date AS thisdate|;
3048 ($thisdate) = selectrow_query($self, $dbh, $query);
3050 $main::lxdebug->leave_sub();
3056 $main::lxdebug->enter_sub();
3058 my ($self, $string) = @_;
3060 if ($string !~ /%/) {
3061 $string = "%$string%";
3064 $string =~ s/\'/\'\'/g;
3066 $main::lxdebug->leave_sub();
3072 $main::lxdebug->enter_sub();
3074 my ($self, $flds, $new, $count, $numrows) = @_;
3078 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3083 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3085 my $j = $item->{ndx} - 1;
3086 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3090 for $i ($count + 1 .. $numrows) {
3091 map { delete $self->{"${_}_$i"} } @{$flds};
3094 $main::lxdebug->leave_sub();
3098 $main::lxdebug->enter_sub();
3100 my ($self, $myconfig) = @_;
3104 my $dbh = $self->dbconnect_noauto($myconfig);
3106 my $query = qq|DELETE FROM status
3107 WHERE (formname = ?) AND (trans_id = ?)|;
3108 my $sth = prepare_query($self, $dbh, $query);
3110 if ($self->{formname} =~ /(check|receipt)/) {
3111 for $i (1 .. $self->{rowcount}) {
3112 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3115 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3119 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3120 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3122 my %queued = split / /, $self->{queued};
3125 if ($self->{formname} =~ /(check|receipt)/) {
3127 # this is a check or receipt, add one entry for each lineitem
3128 my ($accno) = split /--/, $self->{account};
3129 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3130 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3131 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3132 $sth = prepare_query($self, $dbh, $query);
3134 for $i (1 .. $self->{rowcount}) {
3135 if ($self->{"checked_$i"}) {
3136 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3142 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3143 VALUES (?, ?, ?, ?, ?)|;
3144 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3145 $queued{$self->{formname}}, $self->{formname});
3151 $main::lxdebug->leave_sub();
3155 $main::lxdebug->enter_sub();
3157 my ($self, $dbh) = @_;
3159 my ($query, $printed, $emailed);
3161 my $formnames = $self->{printed};
3162 my $emailforms = $self->{emailed};
3164 $query = qq|DELETE FROM status
3165 WHERE (formname = ?) AND (trans_id = ?)|;
3166 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3168 # this only applies to the forms
3169 # checks and receipts are posted when printed or queued
3171 if ($self->{queued}) {
3172 my %queued = split / /, $self->{queued};
3174 foreach my $formname (keys %queued) {
3175 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3176 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3178 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3179 VALUES (?, ?, ?, ?, ?)|;
3180 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3182 $formnames =~ s/\Q$self->{formname}\E//;
3183 $emailforms =~ s/\Q$self->{formname}\E//;
3188 # save printed, emailed info
3189 $formnames =~ s/^ +//g;
3190 $emailforms =~ s/^ +//g;
3193 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3194 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3196 foreach my $formname (keys %status) {
3197 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3198 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3200 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3201 VALUES (?, ?, ?, ?)|;
3202 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3205 $main::lxdebug->leave_sub();
3209 # $main::locale->text('SAVED')
3210 # $main::locale->text('DELETED')
3211 # $main::locale->text('ADDED')
3212 # $main::locale->text('PAYMENT POSTED')
3213 # $main::locale->text('POSTED')
3214 # $main::locale->text('POSTED AS NEW')
3215 # $main::locale->text('ELSE')
3216 # $main::locale->text('SAVED FOR DUNNING')
3217 # $main::locale->text('DUNNING STARTED')
3218 # $main::locale->text('PRINTED')
3219 # $main::locale->text('MAILED')
3220 # $main::locale->text('SCREENED')
3221 # $main::locale->text('CANCELED')
3222 # $main::locale->text('invoice')
3223 # $main::locale->text('proforma')
3224 # $main::locale->text('sales_order')
3225 # $main::locale->text('pick_list')
3226 # $main::locale->text('purchase_order')
3227 # $main::locale->text('bin_list')
3228 # $main::locale->text('sales_quotation')
3229 # $main::locale->text('request_quotation')
3232 $main::lxdebug->enter_sub();
3235 my $dbh = shift || $self->get_standard_dbh;
3237 if(!exists $self->{employee_id}) {
3238 &get_employee($self, $dbh);
3242 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3243 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3244 my @values = (conv_i($self->{id}), $self->{login},
3245 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3246 do_query($self, $dbh, $query, @values);
3250 $main::lxdebug->leave_sub();
3254 $main::lxdebug->enter_sub();
3256 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3257 my ($orderBy, $desc) = split(/\-\-/, $order);
3258 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3261 if ($trans_id ne "") {
3263 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 | .
3264 qq|FROM history_erp h | .
3265 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3266 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3269 my $sth = $dbh->prepare($query) || $self->dberror($query);
3271 $sth->execute() || $self->dberror("$query");
3273 while(my $hash_ref = $sth->fetchrow_hashref()) {
3274 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3275 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3276 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3277 $tempArray[$i++] = $hash_ref;
3279 $main::lxdebug->leave_sub() and return \@tempArray
3280 if ($i > 0 && $tempArray[0] ne "");
3282 $main::lxdebug->leave_sub();
3286 sub update_defaults {
3287 $main::lxdebug->enter_sub();
3289 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3292 if ($provided_dbh) {
3293 $dbh = $provided_dbh;
3295 $dbh = $self->dbconnect_noauto($myconfig);
3297 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3298 my $sth = $dbh->prepare($query);
3300 $sth->execute || $self->dberror($query);
3301 my ($var) = $sth->fetchrow_array;
3304 if ($var =~ m/\d+$/) {
3305 my $new_var = (substr $var, $-[0]) * 1 + 1;
3306 my $len_diff = length($var) - $-[0] - length($new_var);
3307 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3313 $query = qq|UPDATE defaults SET $fld = ?|;
3314 do_query($self, $dbh, $query, $var);
3316 if (!$provided_dbh) {
3321 $main::lxdebug->leave_sub();
3326 sub update_business {
3327 $main::lxdebug->enter_sub();
3329 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3332 if ($provided_dbh) {
3333 $dbh = $provided_dbh;
3335 $dbh = $self->dbconnect_noauto($myconfig);
3338 qq|SELECT customernumberinit FROM business
3339 WHERE id = ? FOR UPDATE|;
3340 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3342 return undef unless $var;
3344 if ($var =~ m/\d+$/) {
3345 my $new_var = (substr $var, $-[0]) * 1 + 1;
3346 my $len_diff = length($var) - $-[0] - length($new_var);
3347 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3353 $query = qq|UPDATE business
3354 SET customernumberinit = ?
3356 do_query($self, $dbh, $query, $var, $business_id);
3358 if (!$provided_dbh) {
3363 $main::lxdebug->leave_sub();
3368 sub get_partsgroup {
3369 $main::lxdebug->enter_sub();
3371 my ($self, $myconfig, $p) = @_;
3372 my $target = $p->{target} || 'all_partsgroup';
3374 my $dbh = $self->get_standard_dbh($myconfig);
3376 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3378 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3381 if ($p->{searchitems} eq 'part') {
3382 $query .= qq|WHERE p.inventory_accno_id > 0|;
3384 if ($p->{searchitems} eq 'service') {
3385 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3387 if ($p->{searchitems} eq 'assembly') {
3388 $query .= qq|WHERE p.assembly = '1'|;
3390 if ($p->{searchitems} eq 'labor') {
3391 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3394 $query .= qq|ORDER BY partsgroup|;
3397 $query = qq|SELECT id, partsgroup FROM partsgroup
3398 ORDER BY partsgroup|;
3401 if ($p->{language_code}) {
3402 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3403 t.description AS translation
3405 JOIN parts p ON (p.partsgroup_id = pg.id)
3406 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3407 ORDER BY translation|;
3408 @values = ($p->{language_code});
3411 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3413 $main::lxdebug->leave_sub();
3416 sub get_pricegroup {
3417 $main::lxdebug->enter_sub();
3419 my ($self, $myconfig, $p) = @_;
3421 my $dbh = $self->get_standard_dbh($myconfig);
3423 my $query = qq|SELECT p.id, p.pricegroup
3426 $query .= qq| ORDER BY pricegroup|;
3429 $query = qq|SELECT id, pricegroup FROM pricegroup
3430 ORDER BY pricegroup|;
3433 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3435 $main::lxdebug->leave_sub();
3439 # usage $form->all_years($myconfig, [$dbh])
3440 # return list of all years where bookings found
3443 $main::lxdebug->enter_sub();
3445 my ($self, $myconfig, $dbh) = @_;
3447 $dbh ||= $self->get_standard_dbh($myconfig);
3450 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3451 (SELECT MAX(transdate) FROM acc_trans)|;
3452 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3454 if ($myconfig->{dateformat} =~ /^yy/) {
3455 ($startdate) = split /\W/, $startdate;
3456 ($enddate) = split /\W/, $enddate;
3458 (@_) = split /\W/, $startdate;
3460 (@_) = split /\W/, $enddate;
3465 $startdate = substr($startdate,0,4);
3466 $enddate = substr($enddate,0,4);
3468 while ($enddate >= $startdate) {
3469 push @all_years, $enddate--;
3474 $main::lxdebug->leave_sub();
3478 $main::lxdebug->enter_sub();
3482 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3484 $main::lxdebug->leave_sub();
3488 $main::lxdebug->enter_sub();
3493 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3495 $main::lxdebug->leave_sub();
3504 SL::Form.pm - main data object.
3508 This is the main data object of Lx-Office.
3509 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3510 Points of interest for a beginner are:
3512 - $form->error - renders a generic error in html. accepts an error message
3513 - $form->get_standard_dbh - returns a database connection for the
3515 =head1 SPECIAL FUNCTIONS
3517 =head2 C<_store_value()>
3519 parses a complex var name, and stores it in the form.
3522 $form->_store_value($key, $value);
3524 keys must start with a string, and can contain various tokens.
3525 supported key structures are:
3528 simple key strings work as expected
3533 separating two keys by a dot (.) will result in a hash lookup for the inner value
3534 this is similar to the behaviour of java and templating mechanisms.
3536 filter.description => $form->{filter}->{description}
3538 3. array+hashref access
3540 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3541 using [+] instead of [] will force a new array index. this is useful for recurring
3542 data structures like part lists. put a [+] into the first varname, and use [] on the
3545 repeating these names in your template:
3548 invoice.items[].parts_id
3552 $form->{invoice}->{items}->[
3566 using brackets at the end of a name will result in a pure array to be created.
3567 note that you mustn't use [+], which is reserved for array+hash access and will
3568 result in undefined behaviour in array context.
3570 filter.status[] => $form->{status}->[ val1, val2, ... ]
3572 =head2 C<update_business> PARAMS
3575 \%config, - config hashref
3576 $business_id, - business id
3577 $dbh - optional database handle
3579 handles business (thats customer/vendor types) sequences.
3581 special behaviour for empty strings in customerinitnumber field:
3582 will in this case not increase the value, and return undef.
3584 =head2 C<redirect_header> $url
3586 Generates a HTTP redirection header for the new C<$url>. Constructs an
3587 absolute URL including scheme, host name and port. If C<$url> is a
3588 relative URL then it is considered relative to Lx-Office base URL.
3590 This function C<die>s if headers have already been created with
3591 C<$::form-E<gt>header>.
3595 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3596 print $::form->redirect_header('http://www.lx-office.org/');
3600 Generates a general purpose http/html header and includes most of the scripts
3601 ans stylesheets needed.
3603 Only one header will be generated. If the method was already called in this
3604 request it will not output anything and return undef. Also if no
3605 HTTP_USER_AGENT is found, no header is generated.
3607 Although header does not accept parameters itself, it will honor special
3608 hashkeys of its Form instance:
3616 If one of these is set, a http-equiv refresh is generated. Missing parameters
3617 default to 3 seconds and the refering url.
3623 If these are arrayrefs the contents will be inlined into the header.
3627 If true, a css snippet will be generated that sets the page in landscape mode.
3631 Used to override the default favicon.
3635 A html page title will be generated from this