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 #======================================================================
67 use List::Util qw(first max min sum);
68 use List::MoreUtils qw(all any apply);
75 disconnect_standard_dbh();
78 sub disconnect_standard_dbh {
79 return unless $standard_dbh;
80 $standard_dbh->disconnect();
85 $main::lxdebug->enter_sub(2);
91 my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
96 $curr = \ $self->{ shift @tokens };
100 my $sep = shift @tokens;
101 my $key = shift @tokens;
103 $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]';
104 $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
105 $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
106 $curr = \ $$curr->{$key}
111 $main::lxdebug->leave_sub(2);
117 $main::lxdebug->enter_sub(2);
122 my @pairs = split(/&/, $input);
125 my ($key, $value) = split(/=/, $_, 2);
126 $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key);
129 $main::lxdebug->leave_sub(2);
132 sub _request_to_hash {
133 $main::lxdebug->enter_sub(2);
139 if (!$ENV{'CONTENT_TYPE'}
140 || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
142 $self->_input_to_hash($input);
144 $main::lxdebug->leave_sub(2);
148 my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
150 my $boundary = '--' . $1;
152 foreach my $line (split m/\n/, $input) {
153 last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
155 if (($line eq $boundary) || ($line eq "$boundary\r")) {
156 ${ $previous } =~ s|\r?\n$|| if $previous;
162 $content_type = "text/plain";
169 next unless $boundary_found;
171 if (!$headers_done) {
172 $line =~ s/[\r\n]*$//;
179 if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
180 if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
182 substr $line, $-[0], $+[0] - $-[0], "";
185 if ($line =~ m|name\s*=\s*"(.*?)"|i) {
187 substr $line, $-[0], $+[0] - $-[0], "";
190 $previous = _store_value($uploads, $name, '') if ($name);
191 $self->{FILENAME} = $filename if ($filename);
196 if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
203 next unless $previous;
205 ${ $previous } .= "${line}\n";
208 ${ $previous } =~ s|\r?\n$|| if $previous;
210 $main::lxdebug->leave_sub(2);
215 sub _recode_recursively {
216 $main::lxdebug->enter_sub();
217 my ($iconv, $param) = @_;
219 if (any { ref $param eq $_ } qw(Form HASH)) {
220 foreach my $key (keys %{ $param }) {
221 if (!ref $param->{$key}) {
222 # Workaround for a bug: converting $param->{$key} directly
223 # leads to 'undef'. I don't know why. Converting a copy works,
225 $param->{$key} = $iconv->convert("" . $param->{$key});
227 _recode_recursively($iconv, $param->{$key});
231 } elsif (ref $param eq 'ARRAY') {
232 foreach my $idx (0 .. scalar(@{ $param }) - 1) {
233 if (!ref $param->[$idx]) {
234 # Workaround for a bug: converting $param->[$idx] directly
235 # leads to 'undef'. I don't know why. Converting a copy works,
237 $param->[$idx] = $iconv->convert("" . $param->[$idx]);
239 _recode_recursively($iconv, $param->[$idx]);
243 $main::lxdebug->leave_sub();
247 $main::lxdebug->enter_sub();
253 if ($LXDebug::watch_form) {
254 require SL::Watchdog;
255 tie %{ $self }, 'SL::Watchdog';
260 $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
261 $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0];
264 if ($ENV{CONTENT_LENGTH}) {
266 read STDIN, $content, $ENV{CONTENT_LENGTH};
267 $uploads = $self->_request_to_hash($content);
270 my $db_charset = $::lx_office_conf{system}->{dbcharset};
271 $db_charset ||= Common::DEFAULT_CHARSET;
273 my $encoding = $self->{INPUT_ENCODING} || $db_charset;
274 delete $self->{INPUT_ENCODING};
276 _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self);
278 map { $self->{$_} = $uploads->{$_} } keys %{ $uploads } if $uploads;
280 #$self->{version} = "2.6.1"; # Old hardcoded but secure style
281 open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file
282 $self->{version} = <VERSION_FILE>;
284 $self->{version} =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code.
286 $main::lxdebug->leave_sub();
291 sub _flatten_variables_rec {
292 $main::lxdebug->enter_sub(2);
301 if ('' eq ref $curr->{$key}) {
302 @result = ({ 'key' => $prefix . $key, 'value' => $curr->{$key} });
304 } elsif ('HASH' eq ref $curr->{$key}) {
305 foreach my $hash_key (sort keys %{ $curr->{$key} }) {
306 push @result, $self->_flatten_variables_rec($curr->{$key}, $prefix . $key . '.', $hash_key);
310 foreach my $idx (0 .. scalar @{ $curr->{$key} } - 1) {
311 my $first_array_entry = 1;
313 foreach my $hash_key (sort keys %{ $curr->{$key}->[$idx] }) {
314 push @result, $self->_flatten_variables_rec($curr->{$key}->[$idx], $prefix . $key . ($first_array_entry ? '[+].' : '[].'), $hash_key);
315 $first_array_entry = 0;
320 $main::lxdebug->leave_sub(2);
325 sub flatten_variables {
326 $main::lxdebug->enter_sub(2);
334 push @variables, $self->_flatten_variables_rec($self, '', $_);
337 $main::lxdebug->leave_sub(2);
342 sub flatten_standard_variables {
343 $main::lxdebug->enter_sub(2);
346 my %skip_keys = map { $_ => 1 } (qw(login password header stylesheet titlebar version), @_);
350 foreach (grep { ! $skip_keys{$_} } keys %{ $self }) {
351 push @variables, $self->_flatten_variables_rec($self, '', $_);
354 $main::lxdebug->leave_sub(2);
360 $main::lxdebug->enter_sub();
366 map { print "$_ = $self->{$_}\n" } (sort keys %{$self});
368 $main::lxdebug->leave_sub();
372 $main::lxdebug->enter_sub(2);
375 my $password = $self->{password};
377 $self->{password} = 'X' x 8;
379 local $Data::Dumper::Sortkeys = 1;
380 my $output = Dumper($self);
382 $self->{password} = $password;
384 $main::lxdebug->leave_sub(2);
390 $main::lxdebug->enter_sub(2);
392 my ($self, $str) = @_;
394 $str = Encode::encode('utf-8-strict', $str) if $::locale->is_utf8;
395 $str =~ s/([^a-zA-Z0-9_.:-])/sprintf("%%%02x", ord($1))/ge;
397 $main::lxdebug->leave_sub(2);
403 $main::lxdebug->enter_sub(2);
405 my ($self, $str) = @_;
410 $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
411 $str = Encode::decode('utf-8-strict', $str) if $::locale->is_utf8;
413 $main::lxdebug->leave_sub(2);
419 $main::lxdebug->enter_sub();
420 my ($self, $str) = @_;
422 if ($str && !ref($str)) {
423 $str =~ s/\"/"/g;
426 $main::lxdebug->leave_sub();
432 $main::lxdebug->enter_sub();
433 my ($self, $str) = @_;
435 if ($str && !ref($str)) {
436 $str =~ s/"/\"/g;
439 $main::lxdebug->leave_sub();
445 $main::lxdebug->enter_sub();
449 map({ print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_);
451 for (sort keys %$self) {
452 next if (($_ eq "header") || (ref($self->{$_}) ne ""));
453 print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n");
456 $main::lxdebug->leave_sub();
460 my ($self, $code) = @_;
461 local $self->{__ERROR_HANDLER} = sub { die({ error => $_[0] }) };
466 $main::lxdebug->enter_sub();
468 $main::lxdebug->show_backtrace();
470 my ($self, $msg) = @_;
472 if ($self->{__ERROR_HANDLER}) {
473 $self->{__ERROR_HANDLER}->($msg);
475 } elsif ($ENV{HTTP_USER_AGENT}) {
477 $self->show_generic_error($msg);
480 print STDERR "Error: $msg\n";
484 $main::lxdebug->leave_sub();
488 $main::lxdebug->enter_sub();
490 my ($self, $msg) = @_;
492 if ($ENV{HTTP_USER_AGENT}) {
495 if (!$self->{header}) {
501 <p class="message_ok"><b>$msg</b></p>
503 <script type="text/javascript">
505 // If JavaScript is enabled, the whole thing will be reloaded.
506 // The reason is: When one changes his menu setup (HTML / XUL / CSS ...)
507 // it now loads the correct code into the browser instead of do nothing.
508 setTimeout("top.frames.location.href='login.pl'",500);
517 if ($self->{info_function}) {
518 &{ $self->{info_function} }($msg);
524 $main::lxdebug->leave_sub();
527 # calculates the number of rows in a textarea based on the content and column number
528 # can be capped with maxrows
530 $main::lxdebug->enter_sub();
531 my ($self, $str, $cols, $maxrows, $minrows) = @_;
535 my $rows = sum map { int((length() - 2) / $cols) + 1 } split /\r/, $str;
538 $main::lxdebug->leave_sub();
540 return max(min($rows, $maxrows), $minrows);
544 $main::lxdebug->enter_sub();
546 my ($self, $msg) = @_;
548 $self->error("$msg\n" . $DBI::errstr);
550 $main::lxdebug->leave_sub();
554 $main::lxdebug->enter_sub();
556 my ($self, $name, $msg) = @_;
559 foreach my $part (split m/\./, $name) {
560 if (!$curr->{$part} || ($curr->{$part} =~ /^\s*$/)) {
563 $curr = $curr->{$part};
566 $main::lxdebug->leave_sub();
569 sub _get_request_uri {
572 return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
574 my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http';
575 my $port = $ENV{SERVER_PORT} || '';
576 $port = undef if (($scheme eq 'http' ) && ($port == 80))
577 || (($scheme eq 'https') && ($port == 443));
579 my $uri = URI->new("${scheme}://");
580 $uri->scheme($scheme);
582 $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
583 $uri->path_query($ENV{REQUEST_URI});
589 sub _add_to_request_uri {
592 my $relative_new_path = shift;
593 my $request_uri = shift || $self->_get_request_uri;
594 my $relative_new_uri = URI->new($relative_new_path);
595 my @request_segments = $request_uri->path_segments;
597 my $new_uri = $request_uri->clone;
598 $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments);
603 sub create_http_response {
604 $main::lxdebug->enter_sub();
609 my $cgi = $main::cgi;
610 $cgi ||= CGI->new('');
613 if (defined $main::auth) {
614 my $uri = $self->_get_request_uri;
615 my @segments = $uri->path_segments;
617 $uri->path_segments(@segments);
619 my $session_cookie_value = $main::auth->get_session_id();
621 if ($session_cookie_value) {
622 $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
623 '-value' => $session_cookie_value,
624 '-path' => $uri->path,
625 '-secure' => $ENV{HTTPS});
629 my %cgi_params = ('-type' => $params{content_type});
630 $cgi_params{'-charset'} = $params{charset} if ($params{charset});
631 $cgi_params{'-cookie'} = $session_cookie if ($session_cookie);
633 map { $cgi_params{'-' . $_} = $params{$_} if exists $params{$_} } qw(content_disposition content_length);
635 my $output = $cgi->header(%cgi_params);
637 $main::lxdebug->leave_sub();
644 $::lxdebug->enter_sub;
646 # extra code is currently only used by menuv3 and menuv4 to set their css.
647 # it is strongly deprecated, and will be changed in a future version.
648 my ($self, $extra_code) = @_;
649 my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
652 $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
654 $self->{favicon} ||= "favicon.ico";
655 $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title};
658 if ($self->{refresh_url} || $self->{refresh_time}) {
659 my $refresh_time = $self->{refresh_time} || 3;
660 my $refresh_url = $self->{refresh_url} || $ENV{REFERER};
661 push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
664 push @header, "<link rel='stylesheet' href='css/$_' type='text/css' title='Lx-Office stylesheet'>"
665 for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets};
667 push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
668 push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
669 push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
670 '<script type="text/javascript" src="js/common.js"></script>',
671 '<style type="text/css">@import url(js/jscalendar/calendar-win2k-1.css);</style>',
672 '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
673 '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
674 '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
675 '<script type="text/javascript" src="js/part_selection.js"></script>';
676 push @header, $self->{javascript} if $self->{javascript};
677 push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
678 push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
679 push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
680 join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title};
682 # if there is a title, we put some JavaScript in to the page, wich writes a
683 # meaningful title-tag for our frameset.
685 if ($self->{title}) {
687 <script type="text/javascript">
689 // Write a meaningful title-tag for our frameset.
690 top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
696 print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
697 print "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01//EN' 'http://www.w3.org/TR/html4/strict.dtd'>\n"
698 if $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/; # Other browsers may choke on menu scripts with DOCTYPE.
702 <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
703 <title>$self->{titlebar}</title>
705 print " $_\n" for @header;
707 <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css" />
708 <meta name="robots" content="noindex,nofollow" />
709 <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
710 <script type="text/javascript" src="js/tabcontent.js">
712 /***********************************************
713 * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
714 * This notice MUST stay intact for legal use
715 * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
716 ***********************************************/
725 $::lxdebug->leave_sub;
728 sub ajax_response_header {
729 $main::lxdebug->enter_sub();
733 my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
734 my $cgi = $main::cgi || CGI->new('');
735 my $output = $cgi->header('-charset' => $db_charset);
737 $main::lxdebug->leave_sub();
742 sub redirect_header {
746 my $base_uri = $self->_get_request_uri;
747 my $new_uri = URI->new_abs($new_url, $base_uri);
749 die "Headers already sent" if $self->{header};
752 my $cgi = $main::cgi || CGI->new('');
753 return $cgi->redirect($new_uri);
756 sub set_standard_title {
757 $::lxdebug->enter_sub;
760 $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
761 $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
762 $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
764 $::lxdebug->leave_sub;
767 sub _prepare_html_template {
768 $main::lxdebug->enter_sub();
770 my ($self, $file, $additional_params) = @_;
773 if (!%::myconfig || !$::myconfig{"countrycode"}) {
774 $language = $::lx_office_conf{system}->{language};
776 $language = $main::myconfig{"countrycode"};
778 $language = "de" unless ($language);
780 if (-f "templates/webpages/${file}.html") {
781 if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
782 my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
783 "Please re-run 'locales.pl' in 'locale/${language}'.";
784 print(qq|<pre>$info</pre>|);
788 $file = "templates/webpages/${file}.html";
791 my $info = "Web page template '${file}' not found.\n";
792 print qq|<pre>$info</pre>|;
796 if ($self->{"DEBUG"}) {
797 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
800 if ($additional_params->{"DEBUG"}) {
801 $additional_params->{"DEBUG"} =
802 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
805 if (%main::myconfig) {
806 $::myconfig{jsc_dateformat} = apply {
810 } $::myconfig{"dateformat"};
811 $additional_params->{"myconfig"} ||= \%::myconfig;
812 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
815 $additional_params->{"conf_dbcharset"} = $::lx_office_conf{system}->{dbcharset};
816 $additional_params->{"conf_webdav"} = $::lx_office_conf{features}->{webdav};
817 $additional_params->{"conf_lizenzen"} = $::lx_office_conf{features}->{lizenzen};
818 $additional_params->{"conf_latex_templates"} = $::lx_office_conf{print_templates}->{latex};
819 $additional_params->{"conf_opendocument_templates"} = $::lx_office_conf{print_templates}->{opendocument};
820 $additional_params->{"conf_vertreter"} = $::lx_office_conf{features}->{vertreter};
821 $additional_params->{"conf_show_best_before"} = $::lx_office_conf{features}->{show_best_before};
822 $additional_params->{"conf_parts_image_css"} = $::lx_office_conf{features}->{parts_image_css};
823 $additional_params->{"conf_parts_listing_images"} = $::lx_office_conf{features}->{parts_listing_images};
824 $additional_params->{"conf_parts_show_image"} = $::lx_office_conf{features}->{parts_show_image};
826 if (%main::debug_options) {
827 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
830 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
831 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
832 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
836 $main::lxdebug->leave_sub();
841 sub parse_html_template {
842 $main::lxdebug->enter_sub();
844 my ($self, $file, $additional_params) = @_;
846 $additional_params ||= { };
848 my $real_file = $self->_prepare_html_template($file, $additional_params);
849 my $template = $self->template || $self->init_template;
851 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
854 $template->process($real_file, $additional_params, \$output) || die $template->error;
856 $main::lxdebug->leave_sub();
864 return if $self->template;
866 return $self->template(Template->new({
871 'PLUGIN_BASE' => 'SL::Template::Plugin',
872 'INCLUDE_PATH' => '.:templates/webpages',
873 'COMPILE_EXT' => '.tcc',
874 'COMPILE_DIR' => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
880 $self->{template_object} = shift if @_;
881 return $self->{template_object};
884 sub show_generic_error {
885 $main::lxdebug->enter_sub();
887 my ($self, $error, %params) = @_;
889 if ($self->{__ERROR_HANDLER}) {
890 $self->{__ERROR_HANDLER}->($error);
891 $main::lxdebug->leave_sub();
896 'title_error' => $params{title},
897 'label_error' => $error,
900 if ($params{action}) {
903 map { delete($self->{$_}); } qw(action);
904 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
906 $add_params->{SHOW_BUTTON} = 1;
907 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
908 $add_params->{VARIABLES} = \@vars;
910 } elsif ($params{back_button}) {
911 $add_params->{SHOW_BACK_BUTTON} = 1;
914 $self->{title} = $params{title} if $params{title};
917 print $self->parse_html_template("generic/error", $add_params);
919 print STDERR "Error: $error\n";
921 $main::lxdebug->leave_sub();
926 sub show_generic_information {
927 $main::lxdebug->enter_sub();
929 my ($self, $text, $title) = @_;
932 'title_information' => $title,
933 'label_information' => $text,
936 $self->{title} = $title if ($title);
939 print $self->parse_html_template("generic/information", $add_params);
941 $main::lxdebug->leave_sub();
946 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
947 # changed it to accept an arbitrary number of triggers - sschoeling
949 $main::lxdebug->enter_sub();
952 my $myconfig = shift;
955 # set dateform for jsscript
958 "dd.mm.yy" => "%d.%m.%Y",
959 "dd-mm-yy" => "%d-%m-%Y",
960 "dd/mm/yy" => "%d/%m/%Y",
961 "mm/dd/yy" => "%m/%d/%Y",
962 "mm-dd-yy" => "%m-%d-%Y",
963 "yyyy-mm-dd" => "%Y-%m-%d",
966 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
967 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
974 inputField : "| . (shift) . qq|",
975 ifFormat :"$ifFormat",
976 align : "| . (shift) . qq|",
977 button : "| . (shift) . qq|"
983 <script type="text/javascript">
984 <!--| . join("", @triggers) . qq|//-->
988 $main::lxdebug->leave_sub();
991 } #end sub write_trigger
994 $main::lxdebug->enter_sub();
996 my ($self, $msg) = @_;
998 if (!$self->{callback}) {
1004 # my ($script, $argv) = split(/\?/, $self->{callback}, 2);
1005 # $script =~ s|.*/||;
1006 # $script =~ s|[^a-zA-Z0-9_\.]||g;
1007 # exec("perl", "$script", $argv);
1009 print $::form->redirect_header($self->{callback});
1011 $main::lxdebug->leave_sub();
1014 # sort of columns removed - empty sub
1016 $main::lxdebug->enter_sub();
1018 my ($self, @columns) = @_;
1020 $main::lxdebug->leave_sub();
1026 $main::lxdebug->enter_sub(2);
1028 my ($self, $myconfig, $amount, $places, $dash) = @_;
1030 if ($amount eq "") {
1034 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1036 my $neg = ($amount =~ s/^-//);
1037 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1039 if (defined($places) && ($places ne '')) {
1045 my ($actual_places) = ($amount =~ /\.(\d+)/);
1046 $actual_places = length($actual_places);
1047 $places = $actual_places > $places ? $actual_places : $places;
1050 $amount = $self->round_amount($amount, $places);
1053 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1054 my @p = split(/\./, $amount); # split amount at decimal point
1056 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1059 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1062 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1063 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1064 ($neg ? "-$amount" : "$amount" ) ;
1068 $main::lxdebug->leave_sub(2);
1072 sub format_amount_units {
1073 $main::lxdebug->enter_sub();
1078 my $myconfig = \%main::myconfig;
1079 my $amount = $params{amount} * 1;
1080 my $places = $params{places};
1081 my $part_unit_name = $params{part_unit};
1082 my $amount_unit_name = $params{amount_unit};
1083 my $conv_units = $params{conv_units};
1084 my $max_places = $params{max_places};
1086 if (!$part_unit_name) {
1087 $main::lxdebug->leave_sub();
1091 AM->retrieve_all_units();
1092 my $all_units = $main::all_units;
1094 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1095 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1098 if (!scalar @{ $conv_units }) {
1099 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1100 $main::lxdebug->leave_sub();
1104 my $part_unit = $all_units->{$part_unit_name};
1105 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1107 $amount *= $conv_unit->{factor};
1112 foreach my $unit (@$conv_units) {
1113 my $last = $unit->{name} eq $part_unit->{name};
1115 $num = int($amount / $unit->{factor});
1116 $amount -= $num * $unit->{factor};
1119 if ($last ? $amount : $num) {
1120 push @values, { "unit" => $unit->{name},
1121 "amount" => $last ? $amount / $unit->{factor} : $num,
1122 "places" => $last ? $places : 0 };
1129 push @values, { "unit" => $part_unit_name,
1134 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1136 $main::lxdebug->leave_sub();
1142 $main::lxdebug->enter_sub(2);
1147 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1148 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1149 $input =~ s/\#\#/\#/g;
1151 $main::lxdebug->leave_sub(2);
1159 $main::lxdebug->enter_sub(2);
1161 my ($self, $myconfig, $amount) = @_;
1163 if ( ($myconfig->{numberformat} eq '1.000,00')
1164 || ($myconfig->{numberformat} eq '1000,00')) {
1169 if ($myconfig->{numberformat} eq "1'000.00") {
1175 $main::lxdebug->leave_sub(2);
1177 return ($amount * 1);
1181 $main::lxdebug->enter_sub(2);
1183 my ($self, $amount, $places) = @_;
1186 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1188 # Round amounts to eight places before rounding to the requested
1189 # number of places. This gets rid of errors due to internal floating
1190 # point representation.
1191 $amount = $self->round_amount($amount, 8) if $places < 8;
1192 $amount = $amount * (10**($places));
1193 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1195 $main::lxdebug->leave_sub(2);
1197 return $round_amount;
1201 sub parse_template {
1202 $main::lxdebug->enter_sub();
1204 my ($self, $myconfig) = @_;
1209 my $userspath = $::lx_office_conf{paths}->{userspath};
1211 $self->{"cwd"} = getcwd();
1212 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1217 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1218 $template_type = 'OpenDocument';
1219 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1221 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1222 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1223 $template_type = 'LaTeX';
1224 $ext_for_format = 'pdf';
1226 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1227 $template_type = 'HTML';
1228 $ext_for_format = 'html';
1230 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1231 $template_type = 'XML';
1232 $ext_for_format = 'xml';
1234 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1235 $template_type = 'XML';
1237 } elsif ( $self->{"format"} =~ /excel/i ) {
1238 $template_type = 'Excel';
1239 $ext_for_format = 'xls';
1241 } elsif ( defined $self->{'format'}) {
1242 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1244 } elsif ( $self->{'format'} eq '' ) {
1245 $self->error("No Outputformat given: $self->{'format'}");
1247 } else { #Catch the rest
1248 $self->error("Outputformat not defined: $self->{'format'}");
1251 my $template = SL::Template::create(type => $template_type,
1252 file_name => $self->{IN},
1254 myconfig => $myconfig,
1255 userspath => $userspath);
1257 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1258 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1260 if (!$self->{employee_id}) {
1261 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1264 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1265 map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1267 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1269 # OUT is used for the media, screen, printer, email
1270 # for postscript we store a copy in a temporary file
1272 my $prepend_userspath;
1274 if (!$self->{tmpfile}) {
1275 $self->{tmpfile} = "${fileid}.$self->{IN}";
1276 $prepend_userspath = 1;
1279 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1281 $self->{tmpfile} =~ s|.*/||;
1282 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1283 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1285 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1286 $out = $self->{OUT};
1287 $self->{OUT} = ">$self->{tmpfile}";
1293 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1294 $result = $template->parse(*OUT);
1299 $result = $template->parse(*STDOUT);
1304 $self->error("$self->{IN} : " . $template->get_error());
1307 if ($self->{media} eq 'file') {
1308 copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1310 chdir("$self->{cwd}");
1312 $::lxdebug->leave_sub();
1317 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1319 if ($self->{media} eq 'email') {
1321 my $mail = new Mailer;
1323 map { $mail->{$_} = $self->{$_} }
1324 qw(cc bcc subject message version format);
1325 $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1326 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1327 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1328 $mail->{fileid} = "$fileid.";
1329 $myconfig->{signature} =~ s/\r//g;
1331 # if we send html or plain text inline
1332 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1333 $mail->{contenttype} = "text/html";
1335 $mail->{message} =~ s/\r//g;
1336 $mail->{message} =~ s/\n/<br>\n/g;
1337 $myconfig->{signature} =~ s/\n/<br>\n/g;
1338 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1340 open(IN, $self->{tmpfile})
1341 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1343 $mail->{message} .= $_;
1350 if (!$self->{"do_not_attach"}) {
1351 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1352 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1353 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1354 "name" => $attachment_name }];
1357 $mail->{message} =~ s/\r//g;
1358 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1362 my $err = $mail->send();
1363 $self->error($self->cleanup . "$err") if ($err);
1367 $self->{OUT} = $out;
1369 my $numbytes = (-s $self->{tmpfile});
1370 open(IN, $self->{tmpfile})
1371 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1374 $self->{copies} = 1 unless $self->{media} eq 'printer';
1376 chdir("$self->{cwd}");
1377 #print(STDERR "Kopien $self->{copies}\n");
1378 #print(STDERR "OUT $self->{OUT}\n");
1379 for my $i (1 .. $self->{copies}) {
1381 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1382 print OUT while <IN>;
1387 $self->{attachment_filename} = ($self->{attachment_filename})
1388 ? $self->{attachment_filename}
1389 : $self->generate_attachment_filename();
1391 # launch application
1392 print qq|Content-Type: | . $template->get_mime_type() . qq|
1393 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1394 Content-Length: $numbytes
1398 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1409 chdir("$self->{cwd}");
1410 $main::lxdebug->leave_sub();
1413 sub get_formname_translation {
1414 $main::lxdebug->enter_sub();
1415 my ($self, $formname) = @_;
1417 $formname ||= $self->{formname};
1419 my %formname_translations = (
1420 bin_list => $main::locale->text('Bin List'),
1421 credit_note => $main::locale->text('Credit Note'),
1422 invoice => $main::locale->text('Invoice'),
1423 pick_list => $main::locale->text('Pick List'),
1424 proforma => $main::locale->text('Proforma Invoice'),
1425 purchase_order => $main::locale->text('Purchase Order'),
1426 request_quotation => $main::locale->text('RFQ'),
1427 sales_order => $main::locale->text('Confirmation'),
1428 sales_quotation => $main::locale->text('Quotation'),
1429 storno_invoice => $main::locale->text('Storno Invoice'),
1430 sales_delivery_order => $main::locale->text('Delivery Order'),
1431 purchase_delivery_order => $main::locale->text('Delivery Order'),
1432 dunning => $main::locale->text('Dunning'),
1435 $main::lxdebug->leave_sub();
1436 return $formname_translations{$formname}
1439 sub get_number_prefix_for_type {
1440 $main::lxdebug->enter_sub();
1444 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1445 : ($self->{type} =~ /_quotation$/) ? 'quo'
1446 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1449 $main::lxdebug->leave_sub();
1453 sub get_extension_for_format {
1454 $main::lxdebug->enter_sub();
1457 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1458 : $self->{format} =~ /postscript/i ? ".ps"
1459 : $self->{format} =~ /opendocument/i ? ".odt"
1460 : $self->{format} =~ /excel/i ? ".xls"
1461 : $self->{format} =~ /html/i ? ".html"
1464 $main::lxdebug->leave_sub();
1468 sub generate_attachment_filename {
1469 $main::lxdebug->enter_sub();
1472 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1473 my $prefix = $self->get_number_prefix_for_type();
1475 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1476 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1478 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1479 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1482 $attachment_filename = "";
1485 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1486 $attachment_filename =~ s|[\s/\\]+|_|g;
1488 $main::lxdebug->leave_sub();
1489 return $attachment_filename;
1492 sub generate_email_subject {
1493 $main::lxdebug->enter_sub();
1496 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1497 my $prefix = $self->get_number_prefix_for_type();
1499 if ($subject && $self->{"${prefix}number"}) {
1500 $subject .= " " . $self->{"${prefix}number"}
1503 $main::lxdebug->leave_sub();
1508 $main::lxdebug->enter_sub();
1512 chdir("$self->{tmpdir}");
1515 if (-f "$self->{tmpfile}.err") {
1516 open(FH, "$self->{tmpfile}.err");
1521 if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1522 $self->{tmpfile} =~ s|.*/||g;
1524 $self->{tmpfile} =~ s/\.\w+$//g;
1525 my $tmpfile = $self->{tmpfile};
1526 unlink(<$tmpfile.*>);
1529 chdir("$self->{cwd}");
1531 $main::lxdebug->leave_sub();
1537 $main::lxdebug->enter_sub();
1539 my ($self, $date, $myconfig) = @_;
1542 if ($date && $date =~ /\D/) {
1544 if ($myconfig->{dateformat} =~ /^yy/) {
1545 ($yy, $mm, $dd) = split /\D/, $date;
1547 if ($myconfig->{dateformat} =~ /^mm/) {
1548 ($mm, $dd, $yy) = split /\D/, $date;
1550 if ($myconfig->{dateformat} =~ /^dd/) {
1551 ($dd, $mm, $yy) = split /\D/, $date;
1556 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1557 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1559 $dd = "0$dd" if ($dd < 10);
1560 $mm = "0$mm" if ($mm < 10);
1562 $date = "$yy$mm$dd";
1565 $main::lxdebug->leave_sub();
1570 # Database routines used throughout
1572 sub _dbconnect_options {
1574 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1581 $main::lxdebug->enter_sub(2);
1583 my ($self, $myconfig) = @_;
1585 # connect to database
1586 my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1590 if ($myconfig->{dboptions}) {
1591 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1594 $main::lxdebug->leave_sub(2);
1599 sub dbconnect_noauto {
1600 $main::lxdebug->enter_sub();
1602 my ($self, $myconfig) = @_;
1604 # connect to database
1605 my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1609 if ($myconfig->{dboptions}) {
1610 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1613 $main::lxdebug->leave_sub();
1618 sub get_standard_dbh {
1619 $main::lxdebug->enter_sub(2);
1622 my $myconfig = shift || \%::myconfig;
1624 if ($standard_dbh && !$standard_dbh->{Active}) {
1625 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1626 undef $standard_dbh;
1629 $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1631 $main::lxdebug->leave_sub(2);
1633 return $standard_dbh;
1637 $main::lxdebug->enter_sub();
1639 my ($self, $date, $myconfig) = @_;
1640 my $dbh = $self->dbconnect($myconfig);
1642 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1643 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1644 my ($closed) = $sth->fetchrow_array;
1646 $main::lxdebug->leave_sub();
1651 sub update_balance {
1652 $main::lxdebug->enter_sub();
1654 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1656 # if we have a value, go do it
1659 # retrieve balance from table
1660 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1661 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1662 my ($balance) = $sth->fetchrow_array;
1668 $query = "UPDATE $table SET $field = $balance WHERE $where";
1669 do_query($self, $dbh, $query, @values);
1671 $main::lxdebug->leave_sub();
1674 sub update_exchangerate {
1675 $main::lxdebug->enter_sub();
1677 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1679 # some sanity check for currency
1681 $main::lxdebug->leave_sub();
1684 $query = qq|SELECT curr FROM defaults|;
1686 my ($currency) = selectrow_query($self, $dbh, $query);
1687 my ($defaultcurrency) = split m/:/, $currency;
1690 if ($curr eq $defaultcurrency) {
1691 $main::lxdebug->leave_sub();
1695 $query = qq|SELECT e.curr FROM exchangerate e
1696 WHERE e.curr = ? AND e.transdate = ?
1698 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1707 $buy = conv_i($buy, "NULL");
1708 $sell = conv_i($sell, "NULL");
1711 if ($buy != 0 && $sell != 0) {
1712 $set = "buy = $buy, sell = $sell";
1713 } elsif ($buy != 0) {
1714 $set = "buy = $buy";
1715 } elsif ($sell != 0) {
1716 $set = "sell = $sell";
1719 if ($sth->fetchrow_array) {
1720 $query = qq|UPDATE exchangerate
1726 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1727 VALUES (?, $buy, $sell, ?)|;
1730 do_query($self, $dbh, $query, $curr, $transdate);
1732 $main::lxdebug->leave_sub();
1735 sub save_exchangerate {
1736 $main::lxdebug->enter_sub();
1738 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1740 my $dbh = $self->dbconnect($myconfig);
1744 $buy = $rate if $fld eq 'buy';
1745 $sell = $rate if $fld eq 'sell';
1748 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1753 $main::lxdebug->leave_sub();
1756 sub get_exchangerate {
1757 $main::lxdebug->enter_sub();
1759 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1762 unless ($transdate) {
1763 $main::lxdebug->leave_sub();
1767 $query = qq|SELECT curr FROM defaults|;
1769 my ($currency) = selectrow_query($self, $dbh, $query);
1770 my ($defaultcurrency) = split m/:/, $currency;
1772 if ($currency eq $defaultcurrency) {
1773 $main::lxdebug->leave_sub();
1777 $query = qq|SELECT e.$fld FROM exchangerate e
1778 WHERE e.curr = ? AND e.transdate = ?|;
1779 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1783 $main::lxdebug->leave_sub();
1785 return $exchangerate;
1788 sub check_exchangerate {
1789 $main::lxdebug->enter_sub();
1791 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1793 if ($fld !~/^buy|sell$/) {
1794 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1797 unless ($transdate) {
1798 $main::lxdebug->leave_sub();
1802 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1804 if ($currency eq $defaultcurrency) {
1805 $main::lxdebug->leave_sub();
1809 my $dbh = $self->get_standard_dbh($myconfig);
1810 my $query = qq|SELECT e.$fld FROM exchangerate e
1811 WHERE e.curr = ? AND e.transdate = ?|;
1813 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1815 $main::lxdebug->leave_sub();
1817 return $exchangerate;
1820 sub get_all_currencies {
1821 $main::lxdebug->enter_sub();
1824 my $myconfig = shift || \%::myconfig;
1825 my $dbh = $self->get_standard_dbh($myconfig);
1827 my $query = qq|SELECT curr FROM defaults|;
1829 my ($curr) = selectrow_query($self, $dbh, $query);
1830 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1832 $main::lxdebug->leave_sub();
1837 sub get_default_currency {
1838 $main::lxdebug->enter_sub();
1840 my ($self, $myconfig) = @_;
1841 my @currencies = $self->get_all_currencies($myconfig);
1843 $main::lxdebug->leave_sub();
1845 return $currencies[0];
1848 sub set_payment_options {
1849 $main::lxdebug->enter_sub();
1851 my ($self, $myconfig, $transdate) = @_;
1853 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1855 my $dbh = $self->get_standard_dbh($myconfig);
1858 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1859 qq|FROM payment_terms p | .
1862 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1863 $self->{payment_terms}) =
1864 selectrow_query($self, $dbh, $query, $self->{payment_id});
1866 if ($transdate eq "") {
1867 if ($self->{invdate}) {
1868 $transdate = $self->{invdate};
1870 $transdate = $self->{transdate};
1875 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1876 qq|FROM payment_terms|;
1877 ($self->{netto_date}, $self->{skonto_date}) =
1878 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1880 my ($invtotal, $total);
1881 my (%amounts, %formatted_amounts);
1883 if ($self->{type} =~ /_order$/) {
1884 $amounts{invtotal} = $self->{ordtotal};
1885 $amounts{total} = $self->{ordtotal};
1887 } elsif ($self->{type} =~ /_quotation$/) {
1888 $amounts{invtotal} = $self->{quototal};
1889 $amounts{total} = $self->{quototal};
1892 $amounts{invtotal} = $self->{invtotal};
1893 $amounts{total} = $self->{total};
1895 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1897 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1899 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1900 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1901 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1903 foreach (keys %amounts) {
1904 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1905 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1908 if ($self->{"language_id"}) {
1910 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1911 qq|FROM translation_payment_terms t | .
1912 qq|LEFT JOIN language l ON t.language_id = l.id | .
1913 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1914 my ($description_long, $output_numberformat, $output_dateformat,
1915 $output_longdates) =
1916 selectrow_query($self, $dbh, $query,
1917 $self->{"language_id"}, $self->{"payment_id"});
1919 $self->{payment_terms} = $description_long if ($description_long);
1921 if ($output_dateformat) {
1922 foreach my $key (qw(netto_date skonto_date)) {
1924 $main::locale->reformat_date($myconfig, $self->{$key},
1930 if ($output_numberformat &&
1931 ($output_numberformat ne $myconfig->{"numberformat"})) {
1932 my $saved_numberformat = $myconfig->{"numberformat"};
1933 $myconfig->{"numberformat"} = $output_numberformat;
1934 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1935 $myconfig->{"numberformat"} = $saved_numberformat;
1939 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1940 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1941 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1942 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1943 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1944 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1945 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1947 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1949 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1951 $main::lxdebug->leave_sub();
1955 sub get_template_language {
1956 $main::lxdebug->enter_sub();
1958 my ($self, $myconfig) = @_;
1960 my $template_code = "";
1962 if ($self->{language_id}) {
1963 my $dbh = $self->get_standard_dbh($myconfig);
1964 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1965 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1968 $main::lxdebug->leave_sub();
1970 return $template_code;
1973 sub get_printer_code {
1974 $main::lxdebug->enter_sub();
1976 my ($self, $myconfig) = @_;
1978 my $template_code = "";
1980 if ($self->{printer_id}) {
1981 my $dbh = $self->get_standard_dbh($myconfig);
1982 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1983 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1986 $main::lxdebug->leave_sub();
1988 return $template_code;
1992 $main::lxdebug->enter_sub();
1994 my ($self, $myconfig) = @_;
1996 my $template_code = "";
1998 if ($self->{shipto_id}) {
1999 my $dbh = $self->get_standard_dbh($myconfig);
2000 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
2001 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
2002 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
2005 $main::lxdebug->leave_sub();
2009 $main::lxdebug->enter_sub();
2011 my ($self, $dbh, $id, $module) = @_;
2016 foreach my $item (qw(name department_1 department_2 street zipcode city country
2017 contact cp_gender phone fax email)) {
2018 if ($self->{"shipto$item"}) {
2019 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2021 push(@values, $self->{"shipto${item}"});
2025 if ($self->{shipto_id}) {
2026 my $query = qq|UPDATE shipto set
2028 shiptodepartment_1 = ?,
2029 shiptodepartment_2 = ?,
2035 shiptocp_gender = ?,
2039 WHERE shipto_id = ?|;
2040 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2042 my $query = qq|SELECT * FROM shipto
2043 WHERE shiptoname = ? AND
2044 shiptodepartment_1 = ? AND
2045 shiptodepartment_2 = ? AND
2046 shiptostreet = ? AND
2047 shiptozipcode = ? AND
2049 shiptocountry = ? AND
2050 shiptocontact = ? AND
2051 shiptocp_gender = ? AND
2057 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2060 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2061 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2062 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2063 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2064 do_query($self, $dbh, $query, $id, @values, $module);
2069 $main::lxdebug->leave_sub();
2073 $main::lxdebug->enter_sub();
2075 my ($self, $dbh) = @_;
2077 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2079 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2080 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2081 $self->{"employee_id"} *= 1;
2083 $main::lxdebug->leave_sub();
2086 sub get_employee_data {
2087 $main::lxdebug->enter_sub();
2092 Common::check_params(\%params, qw(prefix));
2093 Common::check_params_x(\%params, qw(id));
2096 $main::lxdebug->leave_sub();
2100 my $myconfig = \%main::myconfig;
2101 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2103 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2106 my $user = User->new($login);
2107 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2109 $self->{$params{prefix} . '_login'} = $login;
2110 $self->{$params{prefix} . '_name'} ||= $login;
2113 $main::lxdebug->leave_sub();
2117 $main::lxdebug->enter_sub();
2119 my ($self, $myconfig, $reference_date) = @_;
2121 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2123 my $dbh = $self->get_standard_dbh($myconfig);
2124 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2125 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2127 $main::lxdebug->leave_sub();
2133 $main::lxdebug->enter_sub();
2135 my ($self, $dbh, $id, $key) = @_;
2137 $key = "all_contacts" unless ($key);
2141 $main::lxdebug->leave_sub();
2146 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2147 qq|FROM contacts | .
2148 qq|WHERE cp_cv_id = ? | .
2149 qq|ORDER BY lower(cp_name)|;
2151 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2153 $main::lxdebug->leave_sub();
2157 $main::lxdebug->enter_sub();
2159 my ($self, $dbh, $key) = @_;
2161 my ($all, $old_id, $where, @values);
2163 if (ref($key) eq "HASH") {
2166 $key = "ALL_PROJECTS";
2168 foreach my $p (keys(%{$params})) {
2170 $all = $params->{$p};
2171 } elsif ($p eq "old_id") {
2172 $old_id = $params->{$p};
2173 } elsif ($p eq "key") {
2174 $key = $params->{$p};
2180 $where = "WHERE active ";
2182 if (ref($old_id) eq "ARRAY") {
2183 my @ids = grep({ $_ } @{$old_id});
2185 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2186 push(@values, @ids);
2189 $where .= " OR (id = ?) ";
2190 push(@values, $old_id);
2196 qq|SELECT id, projectnumber, description, active | .
2199 qq|ORDER BY lower(projectnumber)|;
2201 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2203 $main::lxdebug->leave_sub();
2207 $main::lxdebug->enter_sub();
2209 my ($self, $dbh, $vc_id, $key) = @_;
2211 $key = "all_shipto" unless ($key);
2214 # get shipping addresses
2215 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2217 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2223 $main::lxdebug->leave_sub();
2227 $main::lxdebug->enter_sub();
2229 my ($self, $dbh, $key) = @_;
2231 $key = "all_printers" unless ($key);
2233 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2235 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2237 $main::lxdebug->leave_sub();
2241 $main::lxdebug->enter_sub();
2243 my ($self, $dbh, $params) = @_;
2246 $key = $params->{key};
2247 $key = "all_charts" unless ($key);
2249 my $transdate = quote_db_date($params->{transdate});
2252 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2254 qq|LEFT JOIN taxkeys tk ON | .
2255 qq|(tk.id = (SELECT id FROM taxkeys | .
2256 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2257 qq| ORDER BY startdate DESC LIMIT 1)) | .
2258 qq|ORDER BY c.accno|;
2260 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2262 $main::lxdebug->leave_sub();
2265 sub _get_taxcharts {
2266 $main::lxdebug->enter_sub();
2268 my ($self, $dbh, $params) = @_;
2270 my $key = "all_taxcharts";
2273 if (ref $params eq 'HASH') {
2274 $key = $params->{key} if ($params->{key});
2275 if ($params->{module} eq 'AR') {
2276 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2278 } elsif ($params->{module} eq 'AP') {
2279 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2286 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2288 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2290 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2292 $main::lxdebug->leave_sub();
2296 $main::lxdebug->enter_sub();
2298 my ($self, $dbh, $key) = @_;
2300 $key = "all_taxzones" unless ($key);
2302 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2304 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2306 $main::lxdebug->leave_sub();
2309 sub _get_employees {
2310 $main::lxdebug->enter_sub();
2312 my ($self, $dbh, $default_key, $key) = @_;
2314 $key = $default_key unless ($key);
2315 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2317 $main::lxdebug->leave_sub();
2320 sub _get_business_types {
2321 $main::lxdebug->enter_sub();
2323 my ($self, $dbh, $key) = @_;
2325 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2326 $options->{key} ||= "all_business_types";
2329 if (exists $options->{salesman}) {
2330 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2333 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2335 $main::lxdebug->leave_sub();
2338 sub _get_languages {
2339 $main::lxdebug->enter_sub();
2341 my ($self, $dbh, $key) = @_;
2343 $key = "all_languages" unless ($key);
2345 my $query = qq|SELECT * FROM language ORDER BY id|;
2347 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2349 $main::lxdebug->leave_sub();
2352 sub _get_dunning_configs {
2353 $main::lxdebug->enter_sub();
2355 my ($self, $dbh, $key) = @_;
2357 $key = "all_dunning_configs" unless ($key);
2359 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2361 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2363 $main::lxdebug->leave_sub();
2366 sub _get_currencies {
2367 $main::lxdebug->enter_sub();
2369 my ($self, $dbh, $key) = @_;
2371 $key = "all_currencies" unless ($key);
2373 my $query = qq|SELECT curr AS currency FROM defaults|;
2375 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2377 $main::lxdebug->leave_sub();
2381 $main::lxdebug->enter_sub();
2383 my ($self, $dbh, $key) = @_;
2385 $key = "all_payments" unless ($key);
2387 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2389 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2391 $main::lxdebug->leave_sub();
2394 sub _get_customers {
2395 $main::lxdebug->enter_sub();
2397 my ($self, $dbh, $key) = @_;
2399 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2400 $options->{key} ||= "all_customers";
2401 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2404 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2405 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2406 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2408 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2409 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2411 $main::lxdebug->leave_sub();
2415 $main::lxdebug->enter_sub();
2417 my ($self, $dbh, $key) = @_;
2419 $key = "all_vendors" unless ($key);
2421 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2423 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2425 $main::lxdebug->leave_sub();
2428 sub _get_departments {
2429 $main::lxdebug->enter_sub();
2431 my ($self, $dbh, $key) = @_;
2433 $key = "all_departments" unless ($key);
2435 my $query = qq|SELECT * FROM department ORDER BY description|;
2437 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2439 $main::lxdebug->leave_sub();
2442 sub _get_warehouses {
2443 $main::lxdebug->enter_sub();
2445 my ($self, $dbh, $param) = @_;
2447 my ($key, $bins_key);
2449 if ('' eq ref $param) {
2453 $key = $param->{key};
2454 $bins_key = $param->{bins};
2457 my $query = qq|SELECT w.* FROM warehouse w
2458 WHERE (NOT w.invalid) AND
2459 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2460 ORDER BY w.sortkey|;
2462 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2465 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?
2466 ORDER BY description|;
2467 my $sth = prepare_query($self, $dbh, $query);
2469 foreach my $warehouse (@{ $self->{$key} }) {
2470 do_statement($self, $sth, $query, $warehouse->{id});
2471 $warehouse->{$bins_key} = [];
2473 while (my $ref = $sth->fetchrow_hashref()) {
2474 push @{ $warehouse->{$bins_key} }, $ref;
2480 $main::lxdebug->leave_sub();
2484 $main::lxdebug->enter_sub();
2486 my ($self, $dbh, $table, $key, $sortkey) = @_;
2488 my $query = qq|SELECT * FROM $table|;
2489 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2491 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2493 $main::lxdebug->leave_sub();
2497 # $main::lxdebug->enter_sub();
2499 # my ($self, $dbh, $key) = @_;
2501 # $key ||= "all_groups";
2503 # my $groups = $main::auth->read_groups();
2505 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2507 # $main::lxdebug->leave_sub();
2511 $main::lxdebug->enter_sub();
2516 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2517 my ($sth, $query, $ref);
2519 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2520 my $vc_id = $self->{"${vc}_id"};
2522 if ($params{"contacts"}) {
2523 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2526 if ($params{"shipto"}) {
2527 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2530 if ($params{"projects"} || $params{"all_projects"}) {
2531 $self->_get_projects($dbh, $params{"all_projects"} ?
2532 $params{"all_projects"} : $params{"projects"},
2533 $params{"all_projects"} ? 1 : 0);
2536 if ($params{"printers"}) {
2537 $self->_get_printers($dbh, $params{"printers"});
2540 if ($params{"languages"}) {
2541 $self->_get_languages($dbh, $params{"languages"});
2544 if ($params{"charts"}) {
2545 $self->_get_charts($dbh, $params{"charts"});
2548 if ($params{"taxcharts"}) {
2549 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2552 if ($params{"taxzones"}) {
2553 $self->_get_taxzones($dbh, $params{"taxzones"});
2556 if ($params{"employees"}) {
2557 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2560 if ($params{"salesmen"}) {
2561 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2564 if ($params{"business_types"}) {
2565 $self->_get_business_types($dbh, $params{"business_types"});
2568 if ($params{"dunning_configs"}) {
2569 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2572 if($params{"currencies"}) {
2573 $self->_get_currencies($dbh, $params{"currencies"});
2576 if($params{"customers"}) {
2577 $self->_get_customers($dbh, $params{"customers"});
2580 if($params{"vendors"}) {
2581 if (ref $params{"vendors"} eq 'HASH') {
2582 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2584 $self->_get_vendors($dbh, $params{"vendors"});
2588 if($params{"payments"}) {
2589 $self->_get_payments($dbh, $params{"payments"});
2592 if($params{"departments"}) {
2593 $self->_get_departments($dbh, $params{"departments"});
2596 if ($params{price_factors}) {
2597 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2600 if ($params{warehouses}) {
2601 $self->_get_warehouses($dbh, $params{warehouses});
2604 # if ($params{groups}) {
2605 # $self->_get_groups($dbh, $params{groups});
2608 if ($params{partsgroup}) {
2609 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2612 $main::lxdebug->leave_sub();
2615 # this sub gets the id and name from $table
2617 $main::lxdebug->enter_sub();
2619 my ($self, $myconfig, $table) = @_;
2621 # connect to database
2622 my $dbh = $self->get_standard_dbh($myconfig);
2624 $table = $table eq "customer" ? "customer" : "vendor";
2625 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2627 my ($query, @values);
2629 if (!$self->{openinvoices}) {
2631 if ($self->{customernumber} ne "") {
2632 $where = qq|(vc.customernumber ILIKE ?)|;
2633 push(@values, '%' . $self->{customernumber} . '%');
2635 $where = qq|(vc.name ILIKE ?)|;
2636 push(@values, '%' . $self->{$table} . '%');
2640 qq~SELECT vc.id, vc.name,
2641 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2643 WHERE $where AND (NOT vc.obsolete)
2647 qq~SELECT DISTINCT vc.id, vc.name,
2648 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2650 JOIN $table vc ON (a.${table}_id = vc.id)
2651 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2653 push(@values, '%' . $self->{$table} . '%');
2656 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2658 $main::lxdebug->leave_sub();
2660 return scalar(@{ $self->{name_list} });
2663 # the selection sub is used in the AR, AP, IS, IR and OE module
2666 $main::lxdebug->enter_sub();
2668 my ($self, $myconfig, $table, $module) = @_;
2671 my $dbh = $self->get_standard_dbh;
2673 $table = $table eq "customer" ? "customer" : "vendor";
2675 my $query = qq|SELECT count(*) FROM $table|;
2676 my ($count) = selectrow_query($self, $dbh, $query);
2678 # build selection list
2679 if ($count <= $myconfig->{vclimit}) {
2680 $query = qq|SELECT id, name, salesman_id
2681 FROM $table WHERE NOT obsolete
2683 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2687 $self->get_employee($dbh);
2689 # setup sales contacts
2690 $query = qq|SELECT e.id, e.name
2692 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2693 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2696 push(@{ $self->{all_employees} },
2697 { id => $self->{employee_id},
2698 name => $self->{employee} });
2700 # sort the whole thing
2701 @{ $self->{all_employees} } =
2702 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2704 if ($module eq 'AR') {
2706 # prepare query for departments
2707 $query = qq|SELECT id, description
2710 ORDER BY description|;
2713 $query = qq|SELECT id, description
2715 ORDER BY description|;
2718 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2721 $query = qq|SELECT id, description
2725 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2728 $query = qq|SELECT printer_description, id
2730 ORDER BY printer_description|;
2732 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2735 $query = qq|SELECT id, description
2739 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2741 $main::lxdebug->leave_sub();
2744 sub language_payment {
2745 $main::lxdebug->enter_sub();
2747 my ($self, $myconfig) = @_;
2749 my $dbh = $self->get_standard_dbh($myconfig);
2751 my $query = qq|SELECT id, description
2755 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2758 $query = qq|SELECT printer_description, id
2760 ORDER BY printer_description|;
2762 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2765 $query = qq|SELECT id, description
2769 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2771 # get buchungsgruppen
2772 $query = qq|SELECT id, description
2773 FROM buchungsgruppen|;
2775 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2777 $main::lxdebug->leave_sub();
2780 # this is only used for reports
2781 sub all_departments {
2782 $main::lxdebug->enter_sub();
2784 my ($self, $myconfig, $table) = @_;
2786 my $dbh = $self->get_standard_dbh($myconfig);
2789 if ($table eq 'customer') {
2790 $where = "WHERE role = 'P' ";
2793 my $query = qq|SELECT id, description
2796 ORDER BY description|;
2797 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2799 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2801 $main::lxdebug->leave_sub();
2805 $main::lxdebug->enter_sub();
2807 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2810 if ($table eq "customer") {
2819 $self->all_vc($myconfig, $table, $module);
2821 # get last customers or vendors
2822 my ($query, $sth, $ref);
2824 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2829 my $transdate = "current_date";
2830 if ($self->{transdate}) {
2831 $transdate = $dbh->quote($self->{transdate});
2834 # now get the account numbers
2835 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2836 FROM chart c, taxkeys tk
2837 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2838 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2841 $sth = $dbh->prepare($query);
2843 do_statement($self, $sth, $query, '%' . $module . '%');
2845 $self->{accounts} = "";
2846 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2848 foreach my $key (split(/:/, $ref->{link})) {
2849 if ($key =~ /\Q$module\E/) {
2851 # cross reference for keys
2852 $xkeyref{ $ref->{accno} } = $key;
2854 push @{ $self->{"${module}_links"}{$key} },
2855 { accno => $ref->{accno},
2856 description => $ref->{description},
2857 taxkey => $ref->{taxkey_id},
2858 tax_id => $ref->{tax_id} };
2860 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2866 # get taxkeys and description
2867 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2868 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2870 if (($module eq "AP") || ($module eq "AR")) {
2871 # get tax rates and description
2872 $query = qq|SELECT * FROM tax|;
2873 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2879 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2880 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2881 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2882 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2884 d.description AS department,
2887 JOIN $table c ON (a.${table}_id = c.id)
2888 LEFT JOIN employee e ON (e.id = a.employee_id)
2889 LEFT JOIN department d ON (d.id = a.department_id)
2891 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2893 foreach my $key (keys %$ref) {
2894 $self->{$key} = $ref->{$key};
2897 my $transdate = "current_date";
2898 if ($self->{transdate}) {
2899 $transdate = $dbh->quote($self->{transdate});
2902 # now get the account numbers
2903 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2905 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2907 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2908 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2911 $sth = $dbh->prepare($query);
2912 do_statement($self, $sth, $query, "%$module%");
2914 $self->{accounts} = "";
2915 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2917 foreach my $key (split(/:/, $ref->{link})) {
2918 if ($key =~ /\Q$module\E/) {
2920 # cross reference for keys
2921 $xkeyref{ $ref->{accno} } = $key;
2923 push @{ $self->{"${module}_links"}{$key} },
2924 { accno => $ref->{accno},
2925 description => $ref->{description},
2926 taxkey => $ref->{taxkey_id},
2927 tax_id => $ref->{tax_id} };
2929 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2935 # get amounts from individual entries
2938 c.accno, c.description,
2939 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2943 LEFT JOIN chart c ON (c.id = a.chart_id)
2944 LEFT JOIN project p ON (p.id = a.project_id)
2945 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2946 WHERE (tk.taxkey_id=a.taxkey) AND
2947 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2948 THEN tk.chart_id = a.chart_id
2951 OR (c.link='%tax%')) AND
2952 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2953 WHERE a.trans_id = ?
2954 AND a.fx_transaction = '0'
2955 ORDER BY a.acc_trans_id, a.transdate|;
2956 $sth = $dbh->prepare($query);
2957 do_statement($self, $sth, $query, $self->{id});
2959 # get exchangerate for currency
2960 $self->{exchangerate} =
2961 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2964 # store amounts in {acc_trans}{$key} for multiple accounts
2965 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2966 $ref->{exchangerate} =
2967 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2968 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2971 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2972 $ref->{amount} *= -1;
2974 $ref->{index} = $index;
2976 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2982 d.curr AS currencies, d.closedto, d.revtrans,
2983 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2984 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2986 $ref = selectfirst_hashref_query($self, $dbh, $query);
2987 map { $self->{$_} = $ref->{$_} } keys %$ref;
2994 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2995 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2996 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2998 $ref = selectfirst_hashref_query($self, $dbh, $query);
2999 map { $self->{$_} = $ref->{$_} } keys %$ref;
3001 if ($self->{"$self->{vc}_id"}) {
3003 # only setup currency
3004 ($self->{currency}) = split(/:/, $self->{currencies});
3008 $self->lastname_used($dbh, $myconfig, $table, $module);
3010 # get exchangerate for currency
3011 $self->{exchangerate} =
3012 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3018 $main::lxdebug->leave_sub();
3022 $main::lxdebug->enter_sub();
3024 my ($self, $dbh, $myconfig, $table, $module) = @_;
3028 $table = $table eq "customer" ? "customer" : "vendor";
3029 my %column_map = ("a.curr" => "currency",
3030 "a.${table}_id" => "${table}_id",
3031 "a.department_id" => "department_id",
3032 "d.description" => "department",
3033 "ct.name" => $table,
3034 "current_date + ct.terms" => "duedate",
3037 if ($self->{type} =~ /delivery_order/) {
3038 $arap = 'delivery_orders';
3039 delete $column_map{"a.curr"};
3041 } elsif ($self->{type} =~ /_order/) {
3043 $where = "quotation = '0'";
3045 } elsif ($self->{type} =~ /_quotation/) {
3047 $where = "quotation = '1'";
3049 } elsif ($table eq 'customer') {
3057 $where = "($where) AND" if ($where);
3058 my $query = qq|SELECT MAX(id) FROM $arap
3059 WHERE $where ${table}_id > 0|;
3060 my ($trans_id) = selectrow_query($self, $dbh, $query);
3063 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3064 $query = qq|SELECT $column_spec
3066 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3067 LEFT JOIN department d ON (a.department_id = d.id)
3069 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3071 map { $self->{$_} = $ref->{$_} } values %column_map;
3073 $main::lxdebug->leave_sub();
3077 $main::lxdebug->enter_sub();
3080 my $myconfig = shift || \%::myconfig;
3081 my ($thisdate, $days) = @_;
3083 my $dbh = $self->get_standard_dbh($myconfig);
3088 my $dateformat = $myconfig->{dateformat};
3089 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3090 $thisdate = $dbh->quote($thisdate);
3091 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3093 $query = qq|SELECT current_date AS thisdate|;
3096 ($thisdate) = selectrow_query($self, $dbh, $query);
3098 $main::lxdebug->leave_sub();
3104 $main::lxdebug->enter_sub();
3106 my ($self, $string) = @_;
3108 if ($string !~ /%/) {
3109 $string = "%$string%";
3112 $string =~ s/\'/\'\'/g;
3114 $main::lxdebug->leave_sub();
3120 $main::lxdebug->enter_sub();
3122 my ($self, $flds, $new, $count, $numrows) = @_;
3126 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3131 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3133 my $j = $item->{ndx} - 1;
3134 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3138 for $i ($count + 1 .. $numrows) {
3139 map { delete $self->{"${_}_$i"} } @{$flds};
3142 $main::lxdebug->leave_sub();
3146 $main::lxdebug->enter_sub();
3148 my ($self, $myconfig) = @_;
3152 my $dbh = $self->dbconnect_noauto($myconfig);
3154 my $query = qq|DELETE FROM status
3155 WHERE (formname = ?) AND (trans_id = ?)|;
3156 my $sth = prepare_query($self, $dbh, $query);
3158 if ($self->{formname} =~ /(check|receipt)/) {
3159 for $i (1 .. $self->{rowcount}) {
3160 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3163 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3167 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3168 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3170 my %queued = split / /, $self->{queued};
3173 if ($self->{formname} =~ /(check|receipt)/) {
3175 # this is a check or receipt, add one entry for each lineitem
3176 my ($accno) = split /--/, $self->{account};
3177 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3178 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3179 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3180 $sth = prepare_query($self, $dbh, $query);
3182 for $i (1 .. $self->{rowcount}) {
3183 if ($self->{"checked_$i"}) {
3184 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3190 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3191 VALUES (?, ?, ?, ?, ?)|;
3192 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3193 $queued{$self->{formname}}, $self->{formname});
3199 $main::lxdebug->leave_sub();
3203 $main::lxdebug->enter_sub();
3205 my ($self, $dbh) = @_;
3207 my ($query, $printed, $emailed);
3209 my $formnames = $self->{printed};
3210 my $emailforms = $self->{emailed};
3212 $query = qq|DELETE FROM status
3213 WHERE (formname = ?) AND (trans_id = ?)|;
3214 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3216 # this only applies to the forms
3217 # checks and receipts are posted when printed or queued
3219 if ($self->{queued}) {
3220 my %queued = split / /, $self->{queued};
3222 foreach my $formname (keys %queued) {
3223 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3224 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3226 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3227 VALUES (?, ?, ?, ?, ?)|;
3228 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3230 $formnames =~ s/\Q$self->{formname}\E//;
3231 $emailforms =~ s/\Q$self->{formname}\E//;
3236 # save printed, emailed info
3237 $formnames =~ s/^ +//g;
3238 $emailforms =~ s/^ +//g;
3241 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3242 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3244 foreach my $formname (keys %status) {
3245 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3246 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3248 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3249 VALUES (?, ?, ?, ?)|;
3250 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3253 $main::lxdebug->leave_sub();
3257 # $main::locale->text('SAVED')
3258 # $main::locale->text('DELETED')
3259 # $main::locale->text('ADDED')
3260 # $main::locale->text('PAYMENT POSTED')
3261 # $main::locale->text('POSTED')
3262 # $main::locale->text('POSTED AS NEW')
3263 # $main::locale->text('ELSE')
3264 # $main::locale->text('SAVED FOR DUNNING')
3265 # $main::locale->text('DUNNING STARTED')
3266 # $main::locale->text('PRINTED')
3267 # $main::locale->text('MAILED')
3268 # $main::locale->text('SCREENED')
3269 # $main::locale->text('CANCELED')
3270 # $main::locale->text('invoice')
3271 # $main::locale->text('proforma')
3272 # $main::locale->text('sales_order')
3273 # $main::locale->text('pick_list')
3274 # $main::locale->text('purchase_order')
3275 # $main::locale->text('bin_list')
3276 # $main::locale->text('sales_quotation')
3277 # $main::locale->text('request_quotation')
3280 $main::lxdebug->enter_sub();
3283 my $dbh = shift || $self->get_standard_dbh;
3285 if(!exists $self->{employee_id}) {
3286 &get_employee($self, $dbh);
3290 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3291 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3292 my @values = (conv_i($self->{id}), $self->{login},
3293 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3294 do_query($self, $dbh, $query, @values);
3298 $main::lxdebug->leave_sub();
3302 $main::lxdebug->enter_sub();
3304 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3305 my ($orderBy, $desc) = split(/\-\-/, $order);
3306 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3309 if ($trans_id ne "") {
3311 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 | .
3312 qq|FROM history_erp h | .
3313 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3314 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3317 my $sth = $dbh->prepare($query) || $self->dberror($query);
3319 $sth->execute() || $self->dberror("$query");
3321 while(my $hash_ref = $sth->fetchrow_hashref()) {
3322 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3323 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3324 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3325 $tempArray[$i++] = $hash_ref;
3327 $main::lxdebug->leave_sub() and return \@tempArray
3328 if ($i > 0 && $tempArray[0] ne "");
3330 $main::lxdebug->leave_sub();
3334 sub update_defaults {
3335 $main::lxdebug->enter_sub();
3337 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3340 if ($provided_dbh) {
3341 $dbh = $provided_dbh;
3343 $dbh = $self->dbconnect_noauto($myconfig);
3345 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3346 my $sth = $dbh->prepare($query);
3348 $sth->execute || $self->dberror($query);
3349 my ($var) = $sth->fetchrow_array;
3352 if ($var =~ m/\d+$/) {
3353 my $new_var = (substr $var, $-[0]) * 1 + 1;
3354 my $len_diff = length($var) - $-[0] - length($new_var);
3355 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3361 $query = qq|UPDATE defaults SET $fld = ?|;
3362 do_query($self, $dbh, $query, $var);
3364 if (!$provided_dbh) {
3369 $main::lxdebug->leave_sub();
3374 sub update_business {
3375 $main::lxdebug->enter_sub();
3377 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3380 if ($provided_dbh) {
3381 $dbh = $provided_dbh;
3383 $dbh = $self->dbconnect_noauto($myconfig);
3386 qq|SELECT customernumberinit FROM business
3387 WHERE id = ? FOR UPDATE|;
3388 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3390 return undef unless $var;
3392 if ($var =~ m/\d+$/) {
3393 my $new_var = (substr $var, $-[0]) * 1 + 1;
3394 my $len_diff = length($var) - $-[0] - length($new_var);
3395 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3401 $query = qq|UPDATE business
3402 SET customernumberinit = ?
3404 do_query($self, $dbh, $query, $var, $business_id);
3406 if (!$provided_dbh) {
3411 $main::lxdebug->leave_sub();
3416 sub get_partsgroup {
3417 $main::lxdebug->enter_sub();
3419 my ($self, $myconfig, $p) = @_;
3420 my $target = $p->{target} || 'all_partsgroup';
3422 my $dbh = $self->get_standard_dbh($myconfig);
3424 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3426 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3429 if ($p->{searchitems} eq 'part') {
3430 $query .= qq|WHERE p.inventory_accno_id > 0|;
3432 if ($p->{searchitems} eq 'service') {
3433 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3435 if ($p->{searchitems} eq 'assembly') {
3436 $query .= qq|WHERE p.assembly = '1'|;
3438 if ($p->{searchitems} eq 'labor') {
3439 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3442 $query .= qq|ORDER BY partsgroup|;
3445 $query = qq|SELECT id, partsgroup FROM partsgroup
3446 ORDER BY partsgroup|;
3449 if ($p->{language_code}) {
3450 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3451 t.description AS translation
3453 JOIN parts p ON (p.partsgroup_id = pg.id)
3454 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3455 ORDER BY translation|;
3456 @values = ($p->{language_code});
3459 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3461 $main::lxdebug->leave_sub();
3464 sub get_pricegroup {
3465 $main::lxdebug->enter_sub();
3467 my ($self, $myconfig, $p) = @_;
3469 my $dbh = $self->get_standard_dbh($myconfig);
3471 my $query = qq|SELECT p.id, p.pricegroup
3474 $query .= qq| ORDER BY pricegroup|;
3477 $query = qq|SELECT id, pricegroup FROM pricegroup
3478 ORDER BY pricegroup|;
3481 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3483 $main::lxdebug->leave_sub();
3487 # usage $form->all_years($myconfig, [$dbh])
3488 # return list of all years where bookings found
3491 $main::lxdebug->enter_sub();
3493 my ($self, $myconfig, $dbh) = @_;
3495 $dbh ||= $self->get_standard_dbh($myconfig);
3498 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3499 (SELECT MAX(transdate) FROM acc_trans)|;
3500 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3502 if ($myconfig->{dateformat} =~ /^yy/) {
3503 ($startdate) = split /\W/, $startdate;
3504 ($enddate) = split /\W/, $enddate;
3506 (@_) = split /\W/, $startdate;
3508 (@_) = split /\W/, $enddate;
3513 $startdate = substr($startdate,0,4);
3514 $enddate = substr($enddate,0,4);
3516 while ($enddate >= $startdate) {
3517 push @all_years, $enddate--;
3522 $main::lxdebug->leave_sub();
3526 $main::lxdebug->enter_sub();
3530 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3532 $main::lxdebug->leave_sub();
3536 $main::lxdebug->enter_sub();
3541 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3543 $main::lxdebug->leave_sub();
3546 sub prepare_for_printing {
3549 $self->{templates} ||= $::myconfig{templates};
3550 $self->{formname} ||= $self->{type};
3551 $self->{media} ||= 'email';
3553 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3555 # set shipto from billto unless set
3556 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3557 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3558 $self->{shiptoname} = $::myconfig{company};
3559 $self->{shiptostreet} = $::myconfig{address};
3562 my $language = $self->{language} ? '_' . $self->{language} : '';
3564 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3565 if ($self->{language_id}) {
3566 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3568 $output_dateformat = $::myconfig{dateformat};
3569 $output_numberformat = $::myconfig{numberformat};
3570 $output_longdates = 1;
3573 # Retrieve accounts for tax calculation.
3574 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3576 if ($self->{type} =~ /_delivery_order$/) {
3577 DO->order_details();
3578 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3579 OE->order_details(\%::myconfig, $self);
3581 IS->invoice_details(\%::myconfig, $self, $::locale);
3584 # Chose extension & set source file name
3585 my $extension = 'html';
3586 if ($self->{format} eq 'postscript') {
3587 $self->{postscript} = 1;
3589 } elsif ($self->{"format"} =~ /pdf/) {
3591 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3592 } elsif ($self->{"format"} =~ /opendocument/) {
3593 $self->{opendocument} = 1;
3595 } elsif ($self->{"format"} =~ /excel/) {
3600 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3601 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3602 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3605 $self->format_dates($output_dateformat, $output_longdates,
3606 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3607 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3608 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3610 $self->reformat_numbers($output_numberformat, 2,
3611 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3612 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3614 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3616 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3618 if (scalar @{ $cvar_date_fields }) {
3619 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3622 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3623 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3630 my ($self, $dateformat, $longformat, @indices) = @_;
3632 $dateformat ||= $::myconfig{dateformat};
3634 foreach my $idx (@indices) {
3635 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3636 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3637 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3641 next unless defined $self->{$idx};
3643 if (!ref($self->{$idx})) {
3644 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3646 } elsif (ref($self->{$idx}) eq "ARRAY") {
3647 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3648 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3654 sub reformat_numbers {
3655 my ($self, $numberformat, $places, @indices) = @_;
3657 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3659 foreach my $idx (@indices) {
3660 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3661 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3662 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3666 next unless defined $self->{$idx};
3668 if (!ref($self->{$idx})) {
3669 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3671 } elsif (ref($self->{$idx}) eq "ARRAY") {
3672 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3673 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3678 my $saved_numberformat = $::myconfig{numberformat};
3679 $::myconfig{numberformat} = $numberformat;
3681 foreach my $idx (@indices) {
3682 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3683 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3684 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3688 next unless defined $self->{$idx};
3690 if (!ref($self->{$idx})) {
3691 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3693 } elsif (ref($self->{$idx}) eq "ARRAY") {
3694 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3695 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3700 $::myconfig{numberformat} = $saved_numberformat;
3709 SL::Form.pm - main data object.
3713 This is the main data object of Lx-Office.
3714 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3715 Points of interest for a beginner are:
3717 - $form->error - renders a generic error in html. accepts an error message
3718 - $form->get_standard_dbh - returns a database connection for the
3720 =head1 SPECIAL FUNCTIONS
3722 =head2 C<_store_value()>
3724 parses a complex var name, and stores it in the form.
3727 $form->_store_value($key, $value);
3729 keys must start with a string, and can contain various tokens.
3730 supported key structures are:
3733 simple key strings work as expected
3738 separating two keys by a dot (.) will result in a hash lookup for the inner value
3739 this is similar to the behaviour of java and templating mechanisms.
3741 filter.description => $form->{filter}->{description}
3743 3. array+hashref access
3745 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3746 using [+] instead of [] will force a new array index. this is useful for recurring
3747 data structures like part lists. put a [+] into the first varname, and use [] on the
3750 repeating these names in your template:
3753 invoice.items[].parts_id
3757 $form->{invoice}->{items}->[
3771 using brackets at the end of a name will result in a pure array to be created.
3772 note that you mustn't use [+], which is reserved for array+hash access and will
3773 result in undefined behaviour in array context.
3775 filter.status[] => $form->{status}->[ val1, val2, ... ]
3777 =head2 C<update_business> PARAMS
3780 \%config, - config hashref
3781 $business_id, - business id
3782 $dbh - optional database handle
3784 handles business (thats customer/vendor types) sequences.
3786 special behaviour for empty strings in customerinitnumber field:
3787 will in this case not increase the value, and return undef.
3789 =head2 C<redirect_header> $url
3791 Generates a HTTP redirection header for the new C<$url>. Constructs an
3792 absolute URL including scheme, host name and port. If C<$url> is a
3793 relative URL then it is considered relative to Lx-Office base URL.
3795 This function C<die>s if headers have already been created with
3796 C<$::form-E<gt>header>.
3800 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3801 print $::form->redirect_header('http://www.lx-office.org/');
3805 Generates a general purpose http/html header and includes most of the scripts
3806 ans stylesheets needed.
3808 Only one header will be generated. If the method was already called in this
3809 request it will not output anything and return undef. Also if no
3810 HTTP_USER_AGENT is found, no header is generated.
3812 Although header does not accept parameters itself, it will honor special
3813 hashkeys of its Form instance:
3821 If one of these is set, a http-equiv refresh is generated. Missing parameters
3822 default to 3 seconds and the refering url.
3828 If these are arrayrefs the contents will be inlined into the header.
3832 If true, a css snippet will be generated that sets the page in landscape mode.
3836 Used to override the default favicon.
3840 A html page title will be generated from this