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}) {
1002 print $::form->redirect_header($self->{callback});
1007 $main::lxdebug->leave_sub();
1010 # sort of columns removed - empty sub
1012 $main::lxdebug->enter_sub();
1014 my ($self, @columns) = @_;
1016 $main::lxdebug->leave_sub();
1022 $main::lxdebug->enter_sub(2);
1024 my ($self, $myconfig, $amount, $places, $dash) = @_;
1026 if ($amount eq "") {
1030 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1032 my $neg = ($amount =~ s/^-//);
1033 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1035 if (defined($places) && ($places ne '')) {
1041 my ($actual_places) = ($amount =~ /\.(\d+)/);
1042 $actual_places = length($actual_places);
1043 $places = $actual_places > $places ? $actual_places : $places;
1046 $amount = $self->round_amount($amount, $places);
1049 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1050 my @p = split(/\./, $amount); # split amount at decimal point
1052 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1055 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1058 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1059 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1060 ($neg ? "-$amount" : "$amount" ) ;
1064 $main::lxdebug->leave_sub(2);
1068 sub format_amount_units {
1069 $main::lxdebug->enter_sub();
1074 my $myconfig = \%main::myconfig;
1075 my $amount = $params{amount} * 1;
1076 my $places = $params{places};
1077 my $part_unit_name = $params{part_unit};
1078 my $amount_unit_name = $params{amount_unit};
1079 my $conv_units = $params{conv_units};
1080 my $max_places = $params{max_places};
1082 if (!$part_unit_name) {
1083 $main::lxdebug->leave_sub();
1087 AM->retrieve_all_units();
1088 my $all_units = $main::all_units;
1090 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1091 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1094 if (!scalar @{ $conv_units }) {
1095 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1096 $main::lxdebug->leave_sub();
1100 my $part_unit = $all_units->{$part_unit_name};
1101 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1103 $amount *= $conv_unit->{factor};
1108 foreach my $unit (@$conv_units) {
1109 my $last = $unit->{name} eq $part_unit->{name};
1111 $num = int($amount / $unit->{factor});
1112 $amount -= $num * $unit->{factor};
1115 if ($last ? $amount : $num) {
1116 push @values, { "unit" => $unit->{name},
1117 "amount" => $last ? $amount / $unit->{factor} : $num,
1118 "places" => $last ? $places : 0 };
1125 push @values, { "unit" => $part_unit_name,
1130 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1132 $main::lxdebug->leave_sub();
1138 $main::lxdebug->enter_sub(2);
1143 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1144 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1145 $input =~ s/\#\#/\#/g;
1147 $main::lxdebug->leave_sub(2);
1155 $main::lxdebug->enter_sub(2);
1157 my ($self, $myconfig, $amount) = @_;
1159 if ( ($myconfig->{numberformat} eq '1.000,00')
1160 || ($myconfig->{numberformat} eq '1000,00')) {
1165 if ($myconfig->{numberformat} eq "1'000.00") {
1171 $main::lxdebug->leave_sub(2);
1173 return ($amount * 1);
1177 $main::lxdebug->enter_sub(2);
1179 my ($self, $amount, $places) = @_;
1182 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1184 # Round amounts to eight places before rounding to the requested
1185 # number of places. This gets rid of errors due to internal floating
1186 # point representation.
1187 $amount = $self->round_amount($amount, 8) if $places < 8;
1188 $amount = $amount * (10**($places));
1189 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1191 $main::lxdebug->leave_sub(2);
1193 return $round_amount;
1197 sub parse_template {
1198 $main::lxdebug->enter_sub();
1200 my ($self, $myconfig) = @_;
1205 my $userspath = $::lx_office_conf{paths}->{userspath};
1206 $self->{"cwd"} = getcwd();
1207 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1212 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1213 $template_type = 'OpenDocument';
1214 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1216 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1217 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1218 $template_type = 'LaTeX';
1219 $ext_for_format = 'pdf';
1221 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1222 $template_type = 'HTML';
1223 $ext_for_format = 'html';
1225 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1226 $template_type = 'XML';
1227 $ext_for_format = 'xml';
1229 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1230 $template_type = 'XML';
1232 } elsif ( $self->{"format"} =~ /excel/i ) {
1233 $template_type = 'Excel';
1234 $ext_for_format = 'xls';
1236 } elsif ( defined $self->{'format'}) {
1237 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1239 } elsif ( $self->{'format'} eq '' ) {
1240 $self->error("No Outputformat given: $self->{'format'}");
1242 } else { #Catch the rest
1243 $self->error("Outputformat not defined: $self->{'format'}");
1246 my $template = SL::Template::create(type => $template_type,
1247 file_name => $self->{IN},
1249 myconfig => $myconfig,
1250 userspath => $userspath);
1252 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1253 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1255 if (!$self->{employee_id}) {
1256 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1259 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1260 map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1262 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1264 # OUT is used for the media, screen, printer, email
1265 # for postscript we store a copy in a temporary file
1267 my $prepend_userspath;
1269 if (!$self->{tmpfile}) {
1270 $self->{tmpfile} = "${fileid}.$self->{IN}";
1271 $prepend_userspath = 1;
1274 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1276 $self->{tmpfile} =~ s|.*/||;
1277 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1278 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1280 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1281 $out = $self->{OUT};
1282 $self->{OUT} = ">$self->{tmpfile}";
1288 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1289 $result = $template->parse(*OUT);
1294 $result = $template->parse(*STDOUT);
1297 Common::copy_file_to_webdav_folder($self) if ($self->{webdav});
1300 $self->error("$self->{IN} : " . $template->get_error());
1303 if ($self->{media} eq 'file') {
1304 copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1306 chdir("$self->{cwd}");
1308 $::lxdebug->leave_sub();
1313 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1315 if ($self->{media} eq 'email') {
1317 my $mail = new Mailer;
1319 map { $mail->{$_} = $self->{$_} }
1320 qw(cc bcc subject message version format);
1321 $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1322 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1323 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1324 $mail->{fileid} = "$fileid.";
1325 $myconfig->{signature} =~ s/\r//g;
1327 # if we send html or plain text inline
1328 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1329 $mail->{contenttype} = "text/html";
1331 $mail->{message} =~ s/\r//g;
1332 $mail->{message} =~ s/\n/<br>\n/g;
1333 $myconfig->{signature} =~ s/\n/<br>\n/g;
1334 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1336 open(IN, $self->{tmpfile})
1337 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1339 $mail->{message} .= $_;
1346 if (!$self->{"do_not_attach"}) {
1347 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1348 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1349 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1350 "name" => $attachment_name }];
1353 $mail->{message} =~ s/\r//g;
1354 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1358 my $err = $mail->send();
1359 $self->error($self->cleanup . "$err") if ($err);
1363 $self->{OUT} = $out;
1365 my $numbytes = (-s $self->{tmpfile});
1366 open(IN, $self->{tmpfile})
1367 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1370 $self->{copies} = 1 unless $self->{media} eq 'printer';
1372 chdir("$self->{cwd}");
1373 #print(STDERR "Kopien $self->{copies}\n");
1374 #print(STDERR "OUT $self->{OUT}\n");
1375 for my $i (1 .. $self->{copies}) {
1377 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1378 print OUT while <IN>;
1383 $self->{attachment_filename} = ($self->{attachment_filename})
1384 ? $self->{attachment_filename}
1385 : $self->generate_attachment_filename();
1387 # launch application
1388 print qq|Content-Type: | . $template->get_mime_type() . qq|
1389 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1390 Content-Length: $numbytes
1394 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1405 chdir("$self->{cwd}");
1406 $main::lxdebug->leave_sub();
1409 sub get_formname_translation {
1410 $main::lxdebug->enter_sub();
1411 my ($self, $formname) = @_;
1413 $formname ||= $self->{formname};
1415 my %formname_translations = (
1416 bin_list => $main::locale->text('Bin List'),
1417 credit_note => $main::locale->text('Credit Note'),
1418 invoice => $main::locale->text('Invoice'),
1419 pick_list => $main::locale->text('Pick List'),
1420 proforma => $main::locale->text('Proforma Invoice'),
1421 purchase_order => $main::locale->text('Purchase Order'),
1422 request_quotation => $main::locale->text('RFQ'),
1423 sales_order => $main::locale->text('Confirmation'),
1424 sales_quotation => $main::locale->text('Quotation'),
1425 storno_invoice => $main::locale->text('Storno Invoice'),
1426 sales_delivery_order => $main::locale->text('Delivery Order'),
1427 purchase_delivery_order => $main::locale->text('Delivery Order'),
1428 dunning => $main::locale->text('Dunning'),
1431 $main::lxdebug->leave_sub();
1432 return $formname_translations{$formname}
1435 sub get_number_prefix_for_type {
1436 $main::lxdebug->enter_sub();
1440 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1441 : ($self->{type} =~ /_quotation$/) ? 'quo'
1442 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1445 $main::lxdebug->leave_sub();
1449 sub get_extension_for_format {
1450 $main::lxdebug->enter_sub();
1453 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1454 : $self->{format} =~ /postscript/i ? ".ps"
1455 : $self->{format} =~ /opendocument/i ? ".odt"
1456 : $self->{format} =~ /excel/i ? ".xls"
1457 : $self->{format} =~ /html/i ? ".html"
1460 $main::lxdebug->leave_sub();
1464 sub generate_attachment_filename {
1465 $main::lxdebug->enter_sub();
1468 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1469 my $prefix = $self->get_number_prefix_for_type();
1471 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1472 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1474 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1475 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1478 $attachment_filename = "";
1481 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1482 $attachment_filename =~ s|[\s/\\]+|_|g;
1484 $main::lxdebug->leave_sub();
1485 return $attachment_filename;
1488 sub generate_email_subject {
1489 $main::lxdebug->enter_sub();
1492 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1493 my $prefix = $self->get_number_prefix_for_type();
1495 if ($subject && $self->{"${prefix}number"}) {
1496 $subject .= " " . $self->{"${prefix}number"}
1499 $main::lxdebug->leave_sub();
1504 $main::lxdebug->enter_sub();
1508 chdir("$self->{tmpdir}");
1511 if (-f "$self->{tmpfile}.err") {
1512 open(FH, "$self->{tmpfile}.err");
1517 if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1518 $self->{tmpfile} =~ s|.*/||g;
1520 $self->{tmpfile} =~ s/\.\w+$//g;
1521 my $tmpfile = $self->{tmpfile};
1522 unlink(<$tmpfile.*>);
1525 chdir("$self->{cwd}");
1527 $main::lxdebug->leave_sub();
1533 $main::lxdebug->enter_sub();
1535 my ($self, $date, $myconfig) = @_;
1538 if ($date && $date =~ /\D/) {
1540 if ($myconfig->{dateformat} =~ /^yy/) {
1541 ($yy, $mm, $dd) = split /\D/, $date;
1543 if ($myconfig->{dateformat} =~ /^mm/) {
1544 ($mm, $dd, $yy) = split /\D/, $date;
1546 if ($myconfig->{dateformat} =~ /^dd/) {
1547 ($dd, $mm, $yy) = split /\D/, $date;
1552 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1553 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1555 $dd = "0$dd" if ($dd < 10);
1556 $mm = "0$mm" if ($mm < 10);
1558 $date = "$yy$mm$dd";
1561 $main::lxdebug->leave_sub();
1566 # Database routines used throughout
1568 sub _dbconnect_options {
1570 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1577 $main::lxdebug->enter_sub(2);
1579 my ($self, $myconfig) = @_;
1581 # connect to database
1582 my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1586 if ($myconfig->{dboptions}) {
1587 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1590 $main::lxdebug->leave_sub(2);
1595 sub dbconnect_noauto {
1596 $main::lxdebug->enter_sub();
1598 my ($self, $myconfig) = @_;
1600 # connect to database
1601 my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1605 if ($myconfig->{dboptions}) {
1606 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1609 $main::lxdebug->leave_sub();
1614 sub get_standard_dbh {
1615 $main::lxdebug->enter_sub(2);
1618 my $myconfig = shift || \%::myconfig;
1620 if ($standard_dbh && !$standard_dbh->{Active}) {
1621 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1622 undef $standard_dbh;
1625 $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1627 $main::lxdebug->leave_sub(2);
1629 return $standard_dbh;
1633 $main::lxdebug->enter_sub();
1635 my ($self, $date, $myconfig) = @_;
1636 my $dbh = $self->dbconnect($myconfig);
1638 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1639 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1640 my ($closed) = $sth->fetchrow_array;
1642 $main::lxdebug->leave_sub();
1647 sub update_balance {
1648 $main::lxdebug->enter_sub();
1650 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1652 # if we have a value, go do it
1655 # retrieve balance from table
1656 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1657 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1658 my ($balance) = $sth->fetchrow_array;
1664 $query = "UPDATE $table SET $field = $balance WHERE $where";
1665 do_query($self, $dbh, $query, @values);
1667 $main::lxdebug->leave_sub();
1670 sub update_exchangerate {
1671 $main::lxdebug->enter_sub();
1673 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1675 # some sanity check for currency
1677 $main::lxdebug->leave_sub();
1680 $query = qq|SELECT curr FROM defaults|;
1682 my ($currency) = selectrow_query($self, $dbh, $query);
1683 my ($defaultcurrency) = split m/:/, $currency;
1686 if ($curr eq $defaultcurrency) {
1687 $main::lxdebug->leave_sub();
1691 $query = qq|SELECT e.curr FROM exchangerate e
1692 WHERE e.curr = ? AND e.transdate = ?
1694 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1703 $buy = conv_i($buy, "NULL");
1704 $sell = conv_i($sell, "NULL");
1707 if ($buy != 0 && $sell != 0) {
1708 $set = "buy = $buy, sell = $sell";
1709 } elsif ($buy != 0) {
1710 $set = "buy = $buy";
1711 } elsif ($sell != 0) {
1712 $set = "sell = $sell";
1715 if ($sth->fetchrow_array) {
1716 $query = qq|UPDATE exchangerate
1722 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1723 VALUES (?, $buy, $sell, ?)|;
1726 do_query($self, $dbh, $query, $curr, $transdate);
1728 $main::lxdebug->leave_sub();
1731 sub save_exchangerate {
1732 $main::lxdebug->enter_sub();
1734 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1736 my $dbh = $self->dbconnect($myconfig);
1740 $buy = $rate if $fld eq 'buy';
1741 $sell = $rate if $fld eq 'sell';
1744 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1749 $main::lxdebug->leave_sub();
1752 sub get_exchangerate {
1753 $main::lxdebug->enter_sub();
1755 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1758 unless ($transdate) {
1759 $main::lxdebug->leave_sub();
1763 $query = qq|SELECT curr FROM defaults|;
1765 my ($currency) = selectrow_query($self, $dbh, $query);
1766 my ($defaultcurrency) = split m/:/, $currency;
1768 if ($currency eq $defaultcurrency) {
1769 $main::lxdebug->leave_sub();
1773 $query = qq|SELECT e.$fld FROM exchangerate e
1774 WHERE e.curr = ? AND e.transdate = ?|;
1775 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1779 $main::lxdebug->leave_sub();
1781 return $exchangerate;
1784 sub check_exchangerate {
1785 $main::lxdebug->enter_sub();
1787 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1789 if ($fld !~/^buy|sell$/) {
1790 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1793 unless ($transdate) {
1794 $main::lxdebug->leave_sub();
1798 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1800 if ($currency eq $defaultcurrency) {
1801 $main::lxdebug->leave_sub();
1805 my $dbh = $self->get_standard_dbh($myconfig);
1806 my $query = qq|SELECT e.$fld FROM exchangerate e
1807 WHERE e.curr = ? AND e.transdate = ?|;
1809 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1811 $main::lxdebug->leave_sub();
1813 return $exchangerate;
1816 sub get_all_currencies {
1817 $main::lxdebug->enter_sub();
1820 my $myconfig = shift || \%::myconfig;
1821 my $dbh = $self->get_standard_dbh($myconfig);
1823 my $query = qq|SELECT curr FROM defaults|;
1825 my ($curr) = selectrow_query($self, $dbh, $query);
1826 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1828 $main::lxdebug->leave_sub();
1833 sub get_default_currency {
1834 $main::lxdebug->enter_sub();
1836 my ($self, $myconfig) = @_;
1837 my @currencies = $self->get_all_currencies($myconfig);
1839 $main::lxdebug->leave_sub();
1841 return $currencies[0];
1844 sub set_payment_options {
1845 $main::lxdebug->enter_sub();
1847 my ($self, $myconfig, $transdate) = @_;
1849 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1851 my $dbh = $self->get_standard_dbh($myconfig);
1854 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1855 qq|FROM payment_terms p | .
1858 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1859 $self->{payment_terms}) =
1860 selectrow_query($self, $dbh, $query, $self->{payment_id});
1862 if ($transdate eq "") {
1863 if ($self->{invdate}) {
1864 $transdate = $self->{invdate};
1866 $transdate = $self->{transdate};
1871 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1872 qq|FROM payment_terms|;
1873 ($self->{netto_date}, $self->{skonto_date}) =
1874 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1876 my ($invtotal, $total);
1877 my (%amounts, %formatted_amounts);
1879 if ($self->{type} =~ /_order$/) {
1880 $amounts{invtotal} = $self->{ordtotal};
1881 $amounts{total} = $self->{ordtotal};
1883 } elsif ($self->{type} =~ /_quotation$/) {
1884 $amounts{invtotal} = $self->{quototal};
1885 $amounts{total} = $self->{quototal};
1888 $amounts{invtotal} = $self->{invtotal};
1889 $amounts{total} = $self->{total};
1891 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1893 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1895 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1896 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1897 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1899 foreach (keys %amounts) {
1900 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1901 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1904 if ($self->{"language_id"}) {
1906 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1907 qq|FROM translation_payment_terms t | .
1908 qq|LEFT JOIN language l ON t.language_id = l.id | .
1909 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1910 my ($description_long, $output_numberformat, $output_dateformat,
1911 $output_longdates) =
1912 selectrow_query($self, $dbh, $query,
1913 $self->{"language_id"}, $self->{"payment_id"});
1915 $self->{payment_terms} = $description_long if ($description_long);
1917 if ($output_dateformat) {
1918 foreach my $key (qw(netto_date skonto_date)) {
1920 $main::locale->reformat_date($myconfig, $self->{$key},
1926 if ($output_numberformat &&
1927 ($output_numberformat ne $myconfig->{"numberformat"})) {
1928 my $saved_numberformat = $myconfig->{"numberformat"};
1929 $myconfig->{"numberformat"} = $output_numberformat;
1930 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1931 $myconfig->{"numberformat"} = $saved_numberformat;
1935 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1936 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1937 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1938 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1939 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1940 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1941 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1943 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1945 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1947 $main::lxdebug->leave_sub();
1951 sub get_template_language {
1952 $main::lxdebug->enter_sub();
1954 my ($self, $myconfig) = @_;
1956 my $template_code = "";
1958 if ($self->{language_id}) {
1959 my $dbh = $self->get_standard_dbh($myconfig);
1960 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1961 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1964 $main::lxdebug->leave_sub();
1966 return $template_code;
1969 sub get_printer_code {
1970 $main::lxdebug->enter_sub();
1972 my ($self, $myconfig) = @_;
1974 my $template_code = "";
1976 if ($self->{printer_id}) {
1977 my $dbh = $self->get_standard_dbh($myconfig);
1978 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1979 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1982 $main::lxdebug->leave_sub();
1984 return $template_code;
1988 $main::lxdebug->enter_sub();
1990 my ($self, $myconfig) = @_;
1992 my $template_code = "";
1994 if ($self->{shipto_id}) {
1995 my $dbh = $self->get_standard_dbh($myconfig);
1996 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1997 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1998 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
2001 $main::lxdebug->leave_sub();
2005 $main::lxdebug->enter_sub();
2007 my ($self, $dbh, $id, $module) = @_;
2012 foreach my $item (qw(name department_1 department_2 street zipcode city country
2013 contact cp_gender phone fax email)) {
2014 if ($self->{"shipto$item"}) {
2015 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2017 push(@values, $self->{"shipto${item}"});
2021 if ($self->{shipto_id}) {
2022 my $query = qq|UPDATE shipto set
2024 shiptodepartment_1 = ?,
2025 shiptodepartment_2 = ?,
2031 shiptocp_gender = ?,
2035 WHERE shipto_id = ?|;
2036 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2038 my $query = qq|SELECT * FROM shipto
2039 WHERE shiptoname = ? AND
2040 shiptodepartment_1 = ? AND
2041 shiptodepartment_2 = ? AND
2042 shiptostreet = ? AND
2043 shiptozipcode = ? AND
2045 shiptocountry = ? AND
2046 shiptocontact = ? AND
2047 shiptocp_gender = ? AND
2053 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2056 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2057 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2058 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2059 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2060 do_query($self, $dbh, $query, $id, @values, $module);
2065 $main::lxdebug->leave_sub();
2069 $main::lxdebug->enter_sub();
2071 my ($self, $dbh) = @_;
2073 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2075 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2076 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2077 $self->{"employee_id"} *= 1;
2079 $main::lxdebug->leave_sub();
2082 sub get_employee_data {
2083 $main::lxdebug->enter_sub();
2088 Common::check_params(\%params, qw(prefix));
2089 Common::check_params_x(\%params, qw(id));
2092 $main::lxdebug->leave_sub();
2096 my $myconfig = \%main::myconfig;
2097 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2099 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2102 my $user = User->new($login);
2103 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2105 $self->{$params{prefix} . '_login'} = $login;
2106 $self->{$params{prefix} . '_name'} ||= $login;
2109 $main::lxdebug->leave_sub();
2113 $main::lxdebug->enter_sub();
2115 my ($self, $myconfig, $reference_date) = @_;
2117 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2119 my $dbh = $self->get_standard_dbh($myconfig);
2120 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2121 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2123 $main::lxdebug->leave_sub();
2129 $main::lxdebug->enter_sub();
2131 my ($self, $dbh, $id, $key) = @_;
2133 $key = "all_contacts" unless ($key);
2137 $main::lxdebug->leave_sub();
2142 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2143 qq|FROM contacts | .
2144 qq|WHERE cp_cv_id = ? | .
2145 qq|ORDER BY lower(cp_name)|;
2147 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2149 $main::lxdebug->leave_sub();
2153 $main::lxdebug->enter_sub();
2155 my ($self, $dbh, $key) = @_;
2157 my ($all, $old_id, $where, @values);
2159 if (ref($key) eq "HASH") {
2162 $key = "ALL_PROJECTS";
2164 foreach my $p (keys(%{$params})) {
2166 $all = $params->{$p};
2167 } elsif ($p eq "old_id") {
2168 $old_id = $params->{$p};
2169 } elsif ($p eq "key") {
2170 $key = $params->{$p};
2176 $where = "WHERE active ";
2178 if (ref($old_id) eq "ARRAY") {
2179 my @ids = grep({ $_ } @{$old_id});
2181 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2182 push(@values, @ids);
2185 $where .= " OR (id = ?) ";
2186 push(@values, $old_id);
2192 qq|SELECT id, projectnumber, description, active | .
2195 qq|ORDER BY lower(projectnumber)|;
2197 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2199 $main::lxdebug->leave_sub();
2203 $main::lxdebug->enter_sub();
2205 my ($self, $dbh, $vc_id, $key) = @_;
2207 $key = "all_shipto" unless ($key);
2210 # get shipping addresses
2211 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2213 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2219 $main::lxdebug->leave_sub();
2223 $main::lxdebug->enter_sub();
2225 my ($self, $dbh, $key) = @_;
2227 $key = "all_printers" unless ($key);
2229 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2231 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2233 $main::lxdebug->leave_sub();
2237 $main::lxdebug->enter_sub();
2239 my ($self, $dbh, $params) = @_;
2242 $key = $params->{key};
2243 $key = "all_charts" unless ($key);
2245 my $transdate = quote_db_date($params->{transdate});
2248 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2250 qq|LEFT JOIN taxkeys tk ON | .
2251 qq|(tk.id = (SELECT id FROM taxkeys | .
2252 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2253 qq| ORDER BY startdate DESC LIMIT 1)) | .
2254 qq|ORDER BY c.accno|;
2256 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2258 $main::lxdebug->leave_sub();
2261 sub _get_taxcharts {
2262 $main::lxdebug->enter_sub();
2264 my ($self, $dbh, $params) = @_;
2266 my $key = "all_taxcharts";
2269 if (ref $params eq 'HASH') {
2270 $key = $params->{key} if ($params->{key});
2271 if ($params->{module} eq 'AR') {
2272 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2274 } elsif ($params->{module} eq 'AP') {
2275 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2282 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2284 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2286 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2288 $main::lxdebug->leave_sub();
2292 $main::lxdebug->enter_sub();
2294 my ($self, $dbh, $key) = @_;
2296 $key = "all_taxzones" unless ($key);
2298 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2300 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2302 $main::lxdebug->leave_sub();
2305 sub _get_employees {
2306 $main::lxdebug->enter_sub();
2308 my ($self, $dbh, $default_key, $key) = @_;
2310 $key = $default_key unless ($key);
2311 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2313 $main::lxdebug->leave_sub();
2316 sub _get_business_types {
2317 $main::lxdebug->enter_sub();
2319 my ($self, $dbh, $key) = @_;
2321 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2322 $options->{key} ||= "all_business_types";
2325 if (exists $options->{salesman}) {
2326 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2329 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2331 $main::lxdebug->leave_sub();
2334 sub _get_languages {
2335 $main::lxdebug->enter_sub();
2337 my ($self, $dbh, $key) = @_;
2339 $key = "all_languages" unless ($key);
2341 my $query = qq|SELECT * FROM language ORDER BY id|;
2343 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2345 $main::lxdebug->leave_sub();
2348 sub _get_dunning_configs {
2349 $main::lxdebug->enter_sub();
2351 my ($self, $dbh, $key) = @_;
2353 $key = "all_dunning_configs" unless ($key);
2355 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2357 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2359 $main::lxdebug->leave_sub();
2362 sub _get_currencies {
2363 $main::lxdebug->enter_sub();
2365 my ($self, $dbh, $key) = @_;
2367 $key = "all_currencies" unless ($key);
2369 my $query = qq|SELECT curr AS currency FROM defaults|;
2371 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2373 $main::lxdebug->leave_sub();
2377 $main::lxdebug->enter_sub();
2379 my ($self, $dbh, $key) = @_;
2381 $key = "all_payments" unless ($key);
2383 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2385 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2387 $main::lxdebug->leave_sub();
2390 sub _get_customers {
2391 $main::lxdebug->enter_sub();
2393 my ($self, $dbh, $key) = @_;
2395 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2396 $options->{key} ||= "all_customers";
2397 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2400 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2401 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2402 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2404 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2405 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2407 $main::lxdebug->leave_sub();
2411 $main::lxdebug->enter_sub();
2413 my ($self, $dbh, $key) = @_;
2415 $key = "all_vendors" unless ($key);
2417 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2419 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2421 $main::lxdebug->leave_sub();
2424 sub _get_departments {
2425 $main::lxdebug->enter_sub();
2427 my ($self, $dbh, $key) = @_;
2429 $key = "all_departments" unless ($key);
2431 my $query = qq|SELECT * FROM department ORDER BY description|;
2433 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2435 $main::lxdebug->leave_sub();
2438 sub _get_warehouses {
2439 $main::lxdebug->enter_sub();
2441 my ($self, $dbh, $param) = @_;
2443 my ($key, $bins_key);
2445 if ('' eq ref $param) {
2449 $key = $param->{key};
2450 $bins_key = $param->{bins};
2453 my $query = qq|SELECT w.* FROM warehouse w
2454 WHERE (NOT w.invalid) AND
2455 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2456 ORDER BY w.sortkey|;
2458 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2461 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?
2462 ORDER BY description|;
2463 my $sth = prepare_query($self, $dbh, $query);
2465 foreach my $warehouse (@{ $self->{$key} }) {
2466 do_statement($self, $sth, $query, $warehouse->{id});
2467 $warehouse->{$bins_key} = [];
2469 while (my $ref = $sth->fetchrow_hashref()) {
2470 push @{ $warehouse->{$bins_key} }, $ref;
2476 $main::lxdebug->leave_sub();
2480 $main::lxdebug->enter_sub();
2482 my ($self, $dbh, $table, $key, $sortkey) = @_;
2484 my $query = qq|SELECT * FROM $table|;
2485 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2487 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2489 $main::lxdebug->leave_sub();
2493 # $main::lxdebug->enter_sub();
2495 # my ($self, $dbh, $key) = @_;
2497 # $key ||= "all_groups";
2499 # my $groups = $main::auth->read_groups();
2501 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2503 # $main::lxdebug->leave_sub();
2507 $main::lxdebug->enter_sub();
2512 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2513 my ($sth, $query, $ref);
2515 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2516 my $vc_id = $self->{"${vc}_id"};
2518 if ($params{"contacts"}) {
2519 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2522 if ($params{"shipto"}) {
2523 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2526 if ($params{"projects"} || $params{"all_projects"}) {
2527 $self->_get_projects($dbh, $params{"all_projects"} ?
2528 $params{"all_projects"} : $params{"projects"},
2529 $params{"all_projects"} ? 1 : 0);
2532 if ($params{"printers"}) {
2533 $self->_get_printers($dbh, $params{"printers"});
2536 if ($params{"languages"}) {
2537 $self->_get_languages($dbh, $params{"languages"});
2540 if ($params{"charts"}) {
2541 $self->_get_charts($dbh, $params{"charts"});
2544 if ($params{"taxcharts"}) {
2545 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2548 if ($params{"taxzones"}) {
2549 $self->_get_taxzones($dbh, $params{"taxzones"});
2552 if ($params{"employees"}) {
2553 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2556 if ($params{"salesmen"}) {
2557 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2560 if ($params{"business_types"}) {
2561 $self->_get_business_types($dbh, $params{"business_types"});
2564 if ($params{"dunning_configs"}) {
2565 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2568 if($params{"currencies"}) {
2569 $self->_get_currencies($dbh, $params{"currencies"});
2572 if($params{"customers"}) {
2573 $self->_get_customers($dbh, $params{"customers"});
2576 if($params{"vendors"}) {
2577 if (ref $params{"vendors"} eq 'HASH') {
2578 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2580 $self->_get_vendors($dbh, $params{"vendors"});
2584 if($params{"payments"}) {
2585 $self->_get_payments($dbh, $params{"payments"});
2588 if($params{"departments"}) {
2589 $self->_get_departments($dbh, $params{"departments"});
2592 if ($params{price_factors}) {
2593 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2596 if ($params{warehouses}) {
2597 $self->_get_warehouses($dbh, $params{warehouses});
2600 # if ($params{groups}) {
2601 # $self->_get_groups($dbh, $params{groups});
2604 if ($params{partsgroup}) {
2605 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2608 $main::lxdebug->leave_sub();
2611 # this sub gets the id and name from $table
2613 $main::lxdebug->enter_sub();
2615 my ($self, $myconfig, $table) = @_;
2617 # connect to database
2618 my $dbh = $self->get_standard_dbh($myconfig);
2620 $table = $table eq "customer" ? "customer" : "vendor";
2621 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2623 my ($query, @values);
2625 if (!$self->{openinvoices}) {
2627 if ($self->{customernumber} ne "") {
2628 $where = qq|(vc.customernumber ILIKE ?)|;
2629 push(@values, '%' . $self->{customernumber} . '%');
2631 $where = qq|(vc.name ILIKE ?)|;
2632 push(@values, '%' . $self->{$table} . '%');
2636 qq~SELECT vc.id, vc.name,
2637 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2639 WHERE $where AND (NOT vc.obsolete)
2643 qq~SELECT DISTINCT vc.id, vc.name,
2644 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2646 JOIN $table vc ON (a.${table}_id = vc.id)
2647 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2649 push(@values, '%' . $self->{$table} . '%');
2652 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2654 $main::lxdebug->leave_sub();
2656 return scalar(@{ $self->{name_list} });
2659 # the selection sub is used in the AR, AP, IS, IR and OE module
2662 $main::lxdebug->enter_sub();
2664 my ($self, $myconfig, $table, $module) = @_;
2667 my $dbh = $self->get_standard_dbh;
2669 $table = $table eq "customer" ? "customer" : "vendor";
2671 my $query = qq|SELECT count(*) FROM $table|;
2672 my ($count) = selectrow_query($self, $dbh, $query);
2674 # build selection list
2675 if ($count <= $myconfig->{vclimit}) {
2676 $query = qq|SELECT id, name, salesman_id
2677 FROM $table WHERE NOT obsolete
2679 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2683 $self->get_employee($dbh);
2685 # setup sales contacts
2686 $query = qq|SELECT e.id, e.name
2688 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2689 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2692 push(@{ $self->{all_employees} },
2693 { id => $self->{employee_id},
2694 name => $self->{employee} });
2696 # sort the whole thing
2697 @{ $self->{all_employees} } =
2698 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2700 if ($module eq 'AR') {
2702 # prepare query for departments
2703 $query = qq|SELECT id, description
2706 ORDER BY description|;
2709 $query = qq|SELECT id, description
2711 ORDER BY description|;
2714 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2717 $query = qq|SELECT id, description
2721 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2724 $query = qq|SELECT printer_description, id
2726 ORDER BY printer_description|;
2728 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2731 $query = qq|SELECT id, description
2735 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2737 $main::lxdebug->leave_sub();
2740 sub language_payment {
2741 $main::lxdebug->enter_sub();
2743 my ($self, $myconfig) = @_;
2745 my $dbh = $self->get_standard_dbh($myconfig);
2747 my $query = qq|SELECT id, description
2751 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2754 $query = qq|SELECT printer_description, id
2756 ORDER BY printer_description|;
2758 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2761 $query = qq|SELECT id, description
2765 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2767 # get buchungsgruppen
2768 $query = qq|SELECT id, description
2769 FROM buchungsgruppen|;
2771 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2773 $main::lxdebug->leave_sub();
2776 # this is only used for reports
2777 sub all_departments {
2778 $main::lxdebug->enter_sub();
2780 my ($self, $myconfig, $table) = @_;
2782 my $dbh = $self->get_standard_dbh($myconfig);
2785 if ($table eq 'customer') {
2786 $where = "WHERE role = 'P' ";
2789 my $query = qq|SELECT id, description
2792 ORDER BY description|;
2793 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2795 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2797 $main::lxdebug->leave_sub();
2801 $main::lxdebug->enter_sub();
2803 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2806 if ($table eq "customer") {
2815 $self->all_vc($myconfig, $table, $module);
2817 # get last customers or vendors
2818 my ($query, $sth, $ref);
2820 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2825 my $transdate = "current_date";
2826 if ($self->{transdate}) {
2827 $transdate = $dbh->quote($self->{transdate});
2830 # now get the account numbers
2831 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2832 FROM chart c, taxkeys tk
2833 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2834 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2837 $sth = $dbh->prepare($query);
2839 do_statement($self, $sth, $query, '%' . $module . '%');
2841 $self->{accounts} = "";
2842 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2844 foreach my $key (split(/:/, $ref->{link})) {
2845 if ($key =~ /\Q$module\E/) {
2847 # cross reference for keys
2848 $xkeyref{ $ref->{accno} } = $key;
2850 push @{ $self->{"${module}_links"}{$key} },
2851 { accno => $ref->{accno},
2852 description => $ref->{description},
2853 taxkey => $ref->{taxkey_id},
2854 tax_id => $ref->{tax_id} };
2856 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2862 # get taxkeys and description
2863 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2864 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2866 if (($module eq "AP") || ($module eq "AR")) {
2867 # get tax rates and description
2868 $query = qq|SELECT * FROM tax|;
2869 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2875 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2876 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2877 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2878 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2880 d.description AS department,
2883 JOIN $table c ON (a.${table}_id = c.id)
2884 LEFT JOIN employee e ON (e.id = a.employee_id)
2885 LEFT JOIN department d ON (d.id = a.department_id)
2887 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2889 foreach my $key (keys %$ref) {
2890 $self->{$key} = $ref->{$key};
2893 my $transdate = "current_date";
2894 if ($self->{transdate}) {
2895 $transdate = $dbh->quote($self->{transdate});
2898 # now get the account numbers
2899 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2901 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2903 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2904 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2907 $sth = $dbh->prepare($query);
2908 do_statement($self, $sth, $query, "%$module%");
2910 $self->{accounts} = "";
2911 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2913 foreach my $key (split(/:/, $ref->{link})) {
2914 if ($key =~ /\Q$module\E/) {
2916 # cross reference for keys
2917 $xkeyref{ $ref->{accno} } = $key;
2919 push @{ $self->{"${module}_links"}{$key} },
2920 { accno => $ref->{accno},
2921 description => $ref->{description},
2922 taxkey => $ref->{taxkey_id},
2923 tax_id => $ref->{tax_id} };
2925 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2931 # get amounts from individual entries
2934 c.accno, c.description,
2935 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2939 LEFT JOIN chart c ON (c.id = a.chart_id)
2940 LEFT JOIN project p ON (p.id = a.project_id)
2941 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2942 WHERE (tk.taxkey_id=a.taxkey) AND
2943 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2944 THEN tk.chart_id = a.chart_id
2947 OR (c.link='%tax%')) AND
2948 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2949 WHERE a.trans_id = ?
2950 AND a.fx_transaction = '0'
2951 ORDER BY a.acc_trans_id, a.transdate|;
2952 $sth = $dbh->prepare($query);
2953 do_statement($self, $sth, $query, $self->{id});
2955 # get exchangerate for currency
2956 $self->{exchangerate} =
2957 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2960 # store amounts in {acc_trans}{$key} for multiple accounts
2961 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2962 $ref->{exchangerate} =
2963 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2964 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2967 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2968 $ref->{amount} *= -1;
2970 $ref->{index} = $index;
2972 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2978 d.curr AS currencies, d.closedto, d.revtrans,
2979 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2980 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2982 $ref = selectfirst_hashref_query($self, $dbh, $query);
2983 map { $self->{$_} = $ref->{$_} } keys %$ref;
2990 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2991 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2992 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2994 $ref = selectfirst_hashref_query($self, $dbh, $query);
2995 map { $self->{$_} = $ref->{$_} } keys %$ref;
2997 if ($self->{"$self->{vc}_id"}) {
2999 # only setup currency
3000 ($self->{currency}) = split(/:/, $self->{currencies});
3004 $self->lastname_used($dbh, $myconfig, $table, $module);
3006 # get exchangerate for currency
3007 $self->{exchangerate} =
3008 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3014 $main::lxdebug->leave_sub();
3018 $main::lxdebug->enter_sub();
3020 my ($self, $dbh, $myconfig, $table, $module) = @_;
3024 $table = $table eq "customer" ? "customer" : "vendor";
3025 my %column_map = ("a.curr" => "currency",
3026 "a.${table}_id" => "${table}_id",
3027 "a.department_id" => "department_id",
3028 "d.description" => "department",
3029 "ct.name" => $table,
3030 "current_date + ct.terms" => "duedate",
3033 if ($self->{type} =~ /delivery_order/) {
3034 $arap = 'delivery_orders';
3035 delete $column_map{"a.curr"};
3037 } elsif ($self->{type} =~ /_order/) {
3039 $where = "quotation = '0'";
3041 } elsif ($self->{type} =~ /_quotation/) {
3043 $where = "quotation = '1'";
3045 } elsif ($table eq 'customer') {
3053 $where = "($where) AND" if ($where);
3054 my $query = qq|SELECT MAX(id) FROM $arap
3055 WHERE $where ${table}_id > 0|;
3056 my ($trans_id) = selectrow_query($self, $dbh, $query);
3059 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3060 $query = qq|SELECT $column_spec
3062 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3063 LEFT JOIN department d ON (a.department_id = d.id)
3065 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3067 map { $self->{$_} = $ref->{$_} } values %column_map;
3069 $main::lxdebug->leave_sub();
3073 $main::lxdebug->enter_sub();
3076 my $myconfig = shift || \%::myconfig;
3077 my ($thisdate, $days) = @_;
3079 my $dbh = $self->get_standard_dbh($myconfig);
3084 my $dateformat = $myconfig->{dateformat};
3085 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3086 $thisdate = $dbh->quote($thisdate);
3087 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3089 $query = qq|SELECT current_date AS thisdate|;
3092 ($thisdate) = selectrow_query($self, $dbh, $query);
3094 $main::lxdebug->leave_sub();
3100 $main::lxdebug->enter_sub();
3102 my ($self, $string) = @_;
3104 if ($string !~ /%/) {
3105 $string = "%$string%";
3108 $string =~ s/\'/\'\'/g;
3110 $main::lxdebug->leave_sub();
3116 $main::lxdebug->enter_sub();
3118 my ($self, $flds, $new, $count, $numrows) = @_;
3122 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3127 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3129 my $j = $item->{ndx} - 1;
3130 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3134 for $i ($count + 1 .. $numrows) {
3135 map { delete $self->{"${_}_$i"} } @{$flds};
3138 $main::lxdebug->leave_sub();
3142 $main::lxdebug->enter_sub();
3144 my ($self, $myconfig) = @_;
3148 my $dbh = $self->dbconnect_noauto($myconfig);
3150 my $query = qq|DELETE FROM status
3151 WHERE (formname = ?) AND (trans_id = ?)|;
3152 my $sth = prepare_query($self, $dbh, $query);
3154 if ($self->{formname} =~ /(check|receipt)/) {
3155 for $i (1 .. $self->{rowcount}) {
3156 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3159 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3163 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3164 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3166 my %queued = split / /, $self->{queued};
3169 if ($self->{formname} =~ /(check|receipt)/) {
3171 # this is a check or receipt, add one entry for each lineitem
3172 my ($accno) = split /--/, $self->{account};
3173 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3174 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3175 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3176 $sth = prepare_query($self, $dbh, $query);
3178 for $i (1 .. $self->{rowcount}) {
3179 if ($self->{"checked_$i"}) {
3180 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3186 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3187 VALUES (?, ?, ?, ?, ?)|;
3188 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3189 $queued{$self->{formname}}, $self->{formname});
3195 $main::lxdebug->leave_sub();
3199 $main::lxdebug->enter_sub();
3201 my ($self, $dbh) = @_;
3203 my ($query, $printed, $emailed);
3205 my $formnames = $self->{printed};
3206 my $emailforms = $self->{emailed};
3208 $query = qq|DELETE FROM status
3209 WHERE (formname = ?) AND (trans_id = ?)|;
3210 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3212 # this only applies to the forms
3213 # checks and receipts are posted when printed or queued
3215 if ($self->{queued}) {
3216 my %queued = split / /, $self->{queued};
3218 foreach my $formname (keys %queued) {
3219 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3220 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3222 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3223 VALUES (?, ?, ?, ?, ?)|;
3224 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3226 $formnames =~ s/\Q$self->{formname}\E//;
3227 $emailforms =~ s/\Q$self->{formname}\E//;
3232 # save printed, emailed info
3233 $formnames =~ s/^ +//g;
3234 $emailforms =~ s/^ +//g;
3237 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3238 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3240 foreach my $formname (keys %status) {
3241 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3242 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3244 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3245 VALUES (?, ?, ?, ?)|;
3246 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3249 $main::lxdebug->leave_sub();
3253 # $main::locale->text('SAVED')
3254 # $main::locale->text('DELETED')
3255 # $main::locale->text('ADDED')
3256 # $main::locale->text('PAYMENT POSTED')
3257 # $main::locale->text('POSTED')
3258 # $main::locale->text('POSTED AS NEW')
3259 # $main::locale->text('ELSE')
3260 # $main::locale->text('SAVED FOR DUNNING')
3261 # $main::locale->text('DUNNING STARTED')
3262 # $main::locale->text('PRINTED')
3263 # $main::locale->text('MAILED')
3264 # $main::locale->text('SCREENED')
3265 # $main::locale->text('CANCELED')
3266 # $main::locale->text('invoice')
3267 # $main::locale->text('proforma')
3268 # $main::locale->text('sales_order')
3269 # $main::locale->text('pick_list')
3270 # $main::locale->text('purchase_order')
3271 # $main::locale->text('bin_list')
3272 # $main::locale->text('sales_quotation')
3273 # $main::locale->text('request_quotation')
3276 $main::lxdebug->enter_sub();
3279 my $dbh = shift || $self->get_standard_dbh;
3281 if(!exists $self->{employee_id}) {
3282 &get_employee($self, $dbh);
3286 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3287 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3288 my @values = (conv_i($self->{id}), $self->{login},
3289 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3290 do_query($self, $dbh, $query, @values);
3294 $main::lxdebug->leave_sub();
3298 $main::lxdebug->enter_sub();
3300 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3301 my ($orderBy, $desc) = split(/\-\-/, $order);
3302 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3305 if ($trans_id ne "") {
3307 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 | .
3308 qq|FROM history_erp h | .
3309 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3310 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3313 my $sth = $dbh->prepare($query) || $self->dberror($query);
3315 $sth->execute() || $self->dberror("$query");
3317 while(my $hash_ref = $sth->fetchrow_hashref()) {
3318 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3319 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3320 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3321 $tempArray[$i++] = $hash_ref;
3323 $main::lxdebug->leave_sub() and return \@tempArray
3324 if ($i > 0 && $tempArray[0] ne "");
3326 $main::lxdebug->leave_sub();
3330 sub update_defaults {
3331 $main::lxdebug->enter_sub();
3333 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3336 if ($provided_dbh) {
3337 $dbh = $provided_dbh;
3339 $dbh = $self->dbconnect_noauto($myconfig);
3341 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3342 my $sth = $dbh->prepare($query);
3344 $sth->execute || $self->dberror($query);
3345 my ($var) = $sth->fetchrow_array;
3348 if ($var =~ m/\d+$/) {
3349 my $new_var = (substr $var, $-[0]) * 1 + 1;
3350 my $len_diff = length($var) - $-[0] - length($new_var);
3351 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3357 $query = qq|UPDATE defaults SET $fld = ?|;
3358 do_query($self, $dbh, $query, $var);
3360 if (!$provided_dbh) {
3365 $main::lxdebug->leave_sub();
3370 sub update_business {
3371 $main::lxdebug->enter_sub();
3373 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3376 if ($provided_dbh) {
3377 $dbh = $provided_dbh;
3379 $dbh = $self->dbconnect_noauto($myconfig);
3382 qq|SELECT customernumberinit FROM business
3383 WHERE id = ? FOR UPDATE|;
3384 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3386 return undef unless $var;
3388 if ($var =~ m/\d+$/) {
3389 my $new_var = (substr $var, $-[0]) * 1 + 1;
3390 my $len_diff = length($var) - $-[0] - length($new_var);
3391 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3397 $query = qq|UPDATE business
3398 SET customernumberinit = ?
3400 do_query($self, $dbh, $query, $var, $business_id);
3402 if (!$provided_dbh) {
3407 $main::lxdebug->leave_sub();
3412 sub get_partsgroup {
3413 $main::lxdebug->enter_sub();
3415 my ($self, $myconfig, $p) = @_;
3416 my $target = $p->{target} || 'all_partsgroup';
3418 my $dbh = $self->get_standard_dbh($myconfig);
3420 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3422 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3425 if ($p->{searchitems} eq 'part') {
3426 $query .= qq|WHERE p.inventory_accno_id > 0|;
3428 if ($p->{searchitems} eq 'service') {
3429 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3431 if ($p->{searchitems} eq 'assembly') {
3432 $query .= qq|WHERE p.assembly = '1'|;
3434 if ($p->{searchitems} eq 'labor') {
3435 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3438 $query .= qq|ORDER BY partsgroup|;
3441 $query = qq|SELECT id, partsgroup FROM partsgroup
3442 ORDER BY partsgroup|;
3445 if ($p->{language_code}) {
3446 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3447 t.description AS translation
3449 JOIN parts p ON (p.partsgroup_id = pg.id)
3450 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3451 ORDER BY translation|;
3452 @values = ($p->{language_code});
3455 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3457 $main::lxdebug->leave_sub();
3460 sub get_pricegroup {
3461 $main::lxdebug->enter_sub();
3463 my ($self, $myconfig, $p) = @_;
3465 my $dbh = $self->get_standard_dbh($myconfig);
3467 my $query = qq|SELECT p.id, p.pricegroup
3470 $query .= qq| ORDER BY pricegroup|;
3473 $query = qq|SELECT id, pricegroup FROM pricegroup
3474 ORDER BY pricegroup|;
3477 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3479 $main::lxdebug->leave_sub();
3483 # usage $form->all_years($myconfig, [$dbh])
3484 # return list of all years where bookings found
3487 $main::lxdebug->enter_sub();
3489 my ($self, $myconfig, $dbh) = @_;
3491 $dbh ||= $self->get_standard_dbh($myconfig);
3494 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3495 (SELECT MAX(transdate) FROM acc_trans)|;
3496 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3498 if ($myconfig->{dateformat} =~ /^yy/) {
3499 ($startdate) = split /\W/, $startdate;
3500 ($enddate) = split /\W/, $enddate;
3502 (@_) = split /\W/, $startdate;
3504 (@_) = split /\W/, $enddate;
3509 $startdate = substr($startdate,0,4);
3510 $enddate = substr($enddate,0,4);
3512 while ($enddate >= $startdate) {
3513 push @all_years, $enddate--;
3518 $main::lxdebug->leave_sub();
3522 $main::lxdebug->enter_sub();
3526 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3528 $main::lxdebug->leave_sub();
3532 $main::lxdebug->enter_sub();
3537 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3539 $main::lxdebug->leave_sub();
3542 sub prepare_for_printing {
3545 $self->{templates} ||= $::myconfig{templates};
3546 $self->{formname} ||= $self->{type};
3547 $self->{media} ||= 'email';
3549 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3551 # set shipto from billto unless set
3552 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3553 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3554 $self->{shiptoname} = $::myconfig{company};
3555 $self->{shiptostreet} = $::myconfig{address};
3558 my $language = $self->{language} ? '_' . $self->{language} : '';
3560 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3561 if ($self->{language_id}) {
3562 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3564 $output_dateformat = $::myconfig{dateformat};
3565 $output_numberformat = $::myconfig{numberformat};
3566 $output_longdates = 1;
3569 # Retrieve accounts for tax calculation.
3570 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3572 if ($self->{type} =~ /_delivery_order$/) {
3573 DO->order_details();
3574 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3575 OE->order_details(\%::myconfig, $self);
3577 IS->invoice_details(\%::myconfig, $self, $::locale);
3580 # Chose extension & set source file name
3581 my $extension = 'html';
3582 if ($self->{format} eq 'postscript') {
3583 $self->{postscript} = 1;
3585 } elsif ($self->{"format"} =~ /pdf/) {
3587 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3588 } elsif ($self->{"format"} =~ /opendocument/) {
3589 $self->{opendocument} = 1;
3591 } elsif ($self->{"format"} =~ /excel/) {
3596 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3597 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3598 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3601 $self->format_dates($output_dateformat, $output_longdates,
3602 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3603 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3604 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3606 $self->reformat_numbers($output_numberformat, 2,
3607 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3608 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3610 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3612 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3614 if (scalar @{ $cvar_date_fields }) {
3615 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3618 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3619 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3626 my ($self, $dateformat, $longformat, @indices) = @_;
3628 $dateformat ||= $::myconfig{dateformat};
3630 foreach my $idx (@indices) {
3631 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3632 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3633 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3637 next unless defined $self->{$idx};
3639 if (!ref($self->{$idx})) {
3640 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3642 } elsif (ref($self->{$idx}) eq "ARRAY") {
3643 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3644 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3650 sub reformat_numbers {
3651 my ($self, $numberformat, $places, @indices) = @_;
3653 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3655 foreach my $idx (@indices) {
3656 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3657 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3658 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3662 next unless defined $self->{$idx};
3664 if (!ref($self->{$idx})) {
3665 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3667 } elsif (ref($self->{$idx}) eq "ARRAY") {
3668 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3669 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3674 my $saved_numberformat = $::myconfig{numberformat};
3675 $::myconfig{numberformat} = $numberformat;
3677 foreach my $idx (@indices) {
3678 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3679 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3680 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3684 next unless defined $self->{$idx};
3686 if (!ref($self->{$idx})) {
3687 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3689 } elsif (ref($self->{$idx}) eq "ARRAY") {
3690 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3691 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3696 $::myconfig{numberformat} = $saved_numberformat;
3705 SL::Form.pm - main data object.
3709 This is the main data object of Lx-Office.
3710 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3711 Points of interest for a beginner are:
3713 - $form->error - renders a generic error in html. accepts an error message
3714 - $form->get_standard_dbh - returns a database connection for the
3716 =head1 SPECIAL FUNCTIONS
3718 =head2 C<_store_value()>
3720 parses a complex var name, and stores it in the form.
3723 $form->_store_value($key, $value);
3725 keys must start with a string, and can contain various tokens.
3726 supported key structures are:
3729 simple key strings work as expected
3734 separating two keys by a dot (.) will result in a hash lookup for the inner value
3735 this is similar to the behaviour of java and templating mechanisms.
3737 filter.description => $form->{filter}->{description}
3739 3. array+hashref access
3741 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3742 using [+] instead of [] will force a new array index. this is useful for recurring
3743 data structures like part lists. put a [+] into the first varname, and use [] on the
3746 repeating these names in your template:
3749 invoice.items[].parts_id
3753 $form->{invoice}->{items}->[
3767 using brackets at the end of a name will result in a pure array to be created.
3768 note that you mustn't use [+], which is reserved for array+hash access and will
3769 result in undefined behaviour in array context.
3771 filter.status[] => $form->{status}->[ val1, val2, ... ]
3773 =head2 C<update_business> PARAMS
3776 \%config, - config hashref
3777 $business_id, - business id
3778 $dbh - optional database handle
3780 handles business (thats customer/vendor types) sequences.
3782 special behaviour for empty strings in customerinitnumber field:
3783 will in this case not increase the value, and return undef.
3785 =head2 C<redirect_header> $url
3787 Generates a HTTP redirection header for the new C<$url>. Constructs an
3788 absolute URL including scheme, host name and port. If C<$url> is a
3789 relative URL then it is considered relative to Lx-Office base URL.
3791 This function C<die>s if headers have already been created with
3792 C<$::form-E<gt>header>.
3796 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3797 print $::form->redirect_header('http://www.lx-office.org/');
3801 Generates a general purpose http/html header and includes most of the scripts
3802 ans stylesheets needed.
3804 Only one header will be generated. If the method was already called in this
3805 request it will not output anything and return undef. Also if no
3806 HTTP_USER_AGENT is found, no header is generated.
3808 Although header does not accept parameters itself, it will honor special
3809 hashkeys of its Form instance:
3817 If one of these is set, a http-equiv refresh is generated. Missing parameters
3818 default to 3 seconds and the refering url.
3824 If these are arrayrefs the contents will be inlined into the header.
3828 If true, a css snippet will be generated that sets the page in landscape mode.
3832 Used to override the default favicon.
3836 A html page title will be generated from this