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 #======================================================================
68 use List::Util qw(first max min sum);
69 use List::MoreUtils qw(all any apply);
76 disconnect_standard_dbh();
79 sub disconnect_standard_dbh {
80 return unless $standard_dbh;
81 $standard_dbh->disconnect();
86 $main::lxdebug->enter_sub(2);
92 my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
97 $curr = \ $self->{ shift @tokens };
101 my $sep = shift @tokens;
102 my $key = shift @tokens;
104 $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]';
105 $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
106 $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
107 $curr = \ $$curr->{$key}
112 $main::lxdebug->leave_sub(2);
118 $main::lxdebug->enter_sub(2);
123 my @pairs = split(/&/, $input);
126 my ($key, $value) = split(/=/, $_, 2);
127 $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key);
130 $main::lxdebug->leave_sub(2);
133 sub _request_to_hash {
134 $main::lxdebug->enter_sub(2);
140 if (!$ENV{'CONTENT_TYPE'}
141 || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
143 $self->_input_to_hash($input);
145 $main::lxdebug->leave_sub(2);
149 my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
151 my $boundary = '--' . $1;
153 foreach my $line (split m/\n/, $input) {
154 last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
156 if (($line eq $boundary) || ($line eq "$boundary\r")) {
157 ${ $previous } =~ s|\r?\n$|| if $previous;
163 $content_type = "text/plain";
170 next unless $boundary_found;
172 if (!$headers_done) {
173 $line =~ s/[\r\n]*$//;
180 if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
181 if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
183 substr $line, $-[0], $+[0] - $-[0], "";
186 if ($line =~ m|name\s*=\s*"(.*?)"|i) {
188 substr $line, $-[0], $+[0] - $-[0], "";
191 $previous = _store_value($uploads, $name, '') if ($name);
192 $self->{FILENAME} = $filename if ($filename);
197 if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
204 next unless $previous;
206 ${ $previous } .= "${line}\n";
209 ${ $previous } =~ s|\r?\n$|| if $previous;
211 $main::lxdebug->leave_sub(2);
216 sub _recode_recursively {
217 $main::lxdebug->enter_sub();
218 my ($iconv, $param) = @_;
220 if (any { ref $param eq $_ } qw(Form HASH)) {
221 foreach my $key (keys %{ $param }) {
222 if (!ref $param->{$key}) {
223 # Workaround for a bug: converting $param->{$key} directly
224 # leads to 'undef'. I don't know why. Converting a copy works,
226 $param->{$key} = $iconv->convert("" . $param->{$key});
228 _recode_recursively($iconv, $param->{$key});
232 } elsif (ref $param eq 'ARRAY') {
233 foreach my $idx (0 .. scalar(@{ $param }) - 1) {
234 if (!ref $param->[$idx]) {
235 # Workaround for a bug: converting $param->[$idx] directly
236 # leads to 'undef'. I don't know why. Converting a copy works,
238 $param->[$idx] = $iconv->convert("" . $param->[$idx]);
240 _recode_recursively($iconv, $param->[$idx]);
244 $main::lxdebug->leave_sub();
248 $main::lxdebug->enter_sub();
254 if ($LXDebug::watch_form) {
255 require SL::Watchdog;
256 tie %{ $self }, 'SL::Watchdog';
261 $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
262 $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0];
265 if ($ENV{CONTENT_LENGTH}) {
267 read STDIN, $content, $ENV{CONTENT_LENGTH};
268 $uploads = $self->_request_to_hash($content);
271 my $db_charset = $::lx_office_conf{system}->{dbcharset};
272 $db_charset ||= Common::DEFAULT_CHARSET;
274 my $encoding = $self->{INPUT_ENCODING} || $db_charset;
275 delete $self->{INPUT_ENCODING};
277 _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self);
279 map { $self->{$_} = $uploads->{$_} } keys %{ $uploads } if $uploads;
281 #$self->{version} = "2.6.1"; # Old hardcoded but secure style
282 open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file
283 $self->{version} = <VERSION_FILE>;
285 $self->{version} =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code.
287 $main::lxdebug->leave_sub();
292 sub _flatten_variables_rec {
293 $main::lxdebug->enter_sub(2);
302 if ('' eq ref $curr->{$key}) {
303 @result = ({ 'key' => $prefix . $key, 'value' => $curr->{$key} });
305 } elsif ('HASH' eq ref $curr->{$key}) {
306 foreach my $hash_key (sort keys %{ $curr->{$key} }) {
307 push @result, $self->_flatten_variables_rec($curr->{$key}, $prefix . $key . '.', $hash_key);
311 foreach my $idx (0 .. scalar @{ $curr->{$key} } - 1) {
312 my $first_array_entry = 1;
314 foreach my $hash_key (sort keys %{ $curr->{$key}->[$idx] }) {
315 push @result, $self->_flatten_variables_rec($curr->{$key}->[$idx], $prefix . $key . ($first_array_entry ? '[+].' : '[].'), $hash_key);
316 $first_array_entry = 0;
321 $main::lxdebug->leave_sub(2);
326 sub flatten_variables {
327 $main::lxdebug->enter_sub(2);
335 push @variables, $self->_flatten_variables_rec($self, '', $_);
338 $main::lxdebug->leave_sub(2);
343 sub flatten_standard_variables {
344 $main::lxdebug->enter_sub(2);
347 my %skip_keys = map { $_ => 1 } (qw(login password header stylesheet titlebar version), @_);
351 foreach (grep { ! $skip_keys{$_} } keys %{ $self }) {
352 push @variables, $self->_flatten_variables_rec($self, '', $_);
355 $main::lxdebug->leave_sub(2);
361 $main::lxdebug->enter_sub();
367 map { print "$_ = $self->{$_}\n" } (sort keys %{$self});
369 $main::lxdebug->leave_sub();
373 $main::lxdebug->enter_sub(2);
376 my $password = $self->{password};
378 $self->{password} = 'X' x 8;
380 local $Data::Dumper::Sortkeys = 1;
381 my $output = Dumper($self);
383 $self->{password} = $password;
385 $main::lxdebug->leave_sub(2);
391 $main::lxdebug->enter_sub(2);
393 my ($self, $str) = @_;
395 $str = Encode::encode('utf-8-strict', $str) if $::locale->is_utf8;
396 $str =~ s/([^a-zA-Z0-9_.:-])/sprintf("%%%02x", ord($1))/ge;
398 $main::lxdebug->leave_sub(2);
404 $main::lxdebug->enter_sub(2);
406 my ($self, $str) = @_;
411 $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
412 $str = Encode::decode('utf-8-strict', $str) if $::locale->is_utf8;
414 $main::lxdebug->leave_sub(2);
420 $main::lxdebug->enter_sub();
421 my ($self, $str) = @_;
423 if ($str && !ref($str)) {
424 $str =~ s/\"/"/g;
427 $main::lxdebug->leave_sub();
433 $main::lxdebug->enter_sub();
434 my ($self, $str) = @_;
436 if ($str && !ref($str)) {
437 $str =~ s/"/\"/g;
440 $main::lxdebug->leave_sub();
446 $main::lxdebug->enter_sub();
450 map({ print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_);
452 for (sort keys %$self) {
453 next if (($_ eq "header") || (ref($self->{$_}) ne ""));
454 print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n");
457 $main::lxdebug->leave_sub();
461 my ($self, $code) = @_;
462 local $self->{__ERROR_HANDLER} = sub { die SL::X::FormError->new($_[0]) };
467 $main::lxdebug->enter_sub();
469 $main::lxdebug->show_backtrace();
471 my ($self, $msg) = @_;
473 if ($self->{__ERROR_HANDLER}) {
474 $self->{__ERROR_HANDLER}->($msg);
476 } elsif ($ENV{HTTP_USER_AGENT}) {
478 $self->show_generic_error($msg);
481 print STDERR "Error: $msg\n";
485 $main::lxdebug->leave_sub();
489 $main::lxdebug->enter_sub();
491 my ($self, $msg) = @_;
493 if ($ENV{HTTP_USER_AGENT}) {
496 if (!$self->{header}) {
502 <p class="message_ok"><b>$msg</b></p>
504 <script type="text/javascript">
506 // If JavaScript is enabled, the whole thing will be reloaded.
507 // The reason is: When one changes his menu setup (HTML / XUL / CSS ...)
508 // it now loads the correct code into the browser instead of do nothing.
509 setTimeout("top.frames.location.href='login.pl'",500);
518 if ($self->{info_function}) {
519 &{ $self->{info_function} }($msg);
525 $main::lxdebug->leave_sub();
528 # calculates the number of rows in a textarea based on the content and column number
529 # can be capped with maxrows
531 $main::lxdebug->enter_sub();
532 my ($self, $str, $cols, $maxrows, $minrows) = @_;
536 my $rows = sum map { int((length() - 2) / $cols) + 1 } split /\r/, $str;
539 $main::lxdebug->leave_sub();
541 return max(min($rows, $maxrows), $minrows);
545 $main::lxdebug->enter_sub();
547 my ($self, $msg) = @_;
549 $self->error("$msg\n" . $DBI::errstr);
551 $main::lxdebug->leave_sub();
555 $main::lxdebug->enter_sub();
557 my ($self, $name, $msg) = @_;
560 foreach my $part (split m/\./, $name) {
561 if (!$curr->{$part} || ($curr->{$part} =~ /^\s*$/)) {
564 $curr = $curr->{$part};
567 $main::lxdebug->leave_sub();
570 sub _get_request_uri {
573 return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
575 my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http';
576 my $port = $ENV{SERVER_PORT} || '';
577 $port = undef if (($scheme eq 'http' ) && ($port == 80))
578 || (($scheme eq 'https') && ($port == 443));
580 my $uri = URI->new("${scheme}://");
581 $uri->scheme($scheme);
583 $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
584 $uri->path_query($ENV{REQUEST_URI});
590 sub _add_to_request_uri {
593 my $relative_new_path = shift;
594 my $request_uri = shift || $self->_get_request_uri;
595 my $relative_new_uri = URI->new($relative_new_path);
596 my @request_segments = $request_uri->path_segments;
598 my $new_uri = $request_uri->clone;
599 $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments);
604 sub create_http_response {
605 $main::lxdebug->enter_sub();
610 my $cgi = $main::cgi;
611 $cgi ||= CGI->new('');
614 if (defined $main::auth) {
615 my $uri = $self->_get_request_uri;
616 my @segments = $uri->path_segments;
618 $uri->path_segments(@segments);
620 my $session_cookie_value = $main::auth->get_session_id();
622 if ($session_cookie_value) {
623 $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
624 '-value' => $session_cookie_value,
625 '-path' => $uri->path,
626 '-secure' => $ENV{HTTPS});
630 my %cgi_params = ('-type' => $params{content_type});
631 $cgi_params{'-charset'} = $params{charset} if ($params{charset});
632 $cgi_params{'-cookie'} = $session_cookie if ($session_cookie);
634 map { $cgi_params{'-' . $_} = $params{$_} if exists $params{$_} } qw(content_disposition content_length);
636 my $output = $cgi->header(%cgi_params);
638 $main::lxdebug->leave_sub();
645 $::lxdebug->enter_sub;
647 # extra code is currently only used by menuv3 and menuv4 to set their css.
648 # it is strongly deprecated, and will be changed in a future version.
649 my ($self, $extra_code) = @_;
650 my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
653 $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
655 $self->{favicon} ||= "favicon.ico";
656 $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title};
659 if ($self->{refresh_url} || $self->{refresh_time}) {
660 my $refresh_time = $self->{refresh_time} || 3;
661 my $refresh_url = $self->{refresh_url} || $ENV{REFERER};
662 push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
665 push @header, "<link rel='stylesheet' href='css/$_' type='text/css' title='Lx-Office stylesheet'>"
666 for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets};
668 push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
669 push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
670 push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
671 '<script type="text/javascript" src="js/common.js"></script>',
672 '<style type="text/css">@import url(js/jscalendar/calendar-win2k-1.css);</style>',
673 '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
674 '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
675 '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
676 '<script type="text/javascript" src="js/part_selection.js"></script>';
677 push @header, $self->{javascript} if $self->{javascript};
678 push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
679 push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
680 push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
681 join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title};
683 # if there is a title, we put some JavaScript in to the page, wich writes a
684 # meaningful title-tag for our frameset.
686 if ($self->{title}) {
688 <script type="text/javascript">
690 // Write a meaningful title-tag for our frameset.
691 top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
697 print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
698 print "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01//EN' 'http://www.w3.org/TR/html4/strict.dtd'>\n"
699 if $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/; # Other browsers may choke on menu scripts with DOCTYPE.
703 <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
704 <title>$self->{titlebar}</title>
706 print " $_\n" for @header;
708 <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css" />
709 <meta name="robots" content="noindex,nofollow" />
710 <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
711 <script type="text/javascript" src="js/tabcontent.js">
713 /***********************************************
714 * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
715 * This notice MUST stay intact for legal use
716 * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
717 ***********************************************/
726 $::lxdebug->leave_sub;
729 sub ajax_response_header {
730 $main::lxdebug->enter_sub();
734 my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
735 my $cgi = $main::cgi || CGI->new('');
736 my $output = $cgi->header('-charset' => $db_charset);
738 $main::lxdebug->leave_sub();
743 sub redirect_header {
747 my $base_uri = $self->_get_request_uri;
748 my $new_uri = URI->new_abs($new_url, $base_uri);
750 die "Headers already sent" if $self->{header};
753 my $cgi = $main::cgi || CGI->new('');
754 return $cgi->redirect($new_uri);
757 sub set_standard_title {
758 $::lxdebug->enter_sub;
761 $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
762 $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
763 $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
765 $::lxdebug->leave_sub;
768 sub _prepare_html_template {
769 $main::lxdebug->enter_sub();
771 my ($self, $file, $additional_params) = @_;
774 if (!%::myconfig || !$::myconfig{"countrycode"}) {
775 $language = $::lx_office_conf{system}->{language};
777 $language = $main::myconfig{"countrycode"};
779 $language = "de" unless ($language);
781 if (-f "templates/webpages/${file}.html") {
782 if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
783 my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
784 "Please re-run 'locales.pl' in 'locale/${language}'.";
785 print(qq|<pre>$info</pre>|);
789 $file = "templates/webpages/${file}.html";
792 my $info = "Web page template '${file}' not found.\n";
793 print qq|<pre>$info</pre>|;
797 if ($self->{"DEBUG"}) {
798 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
801 if ($additional_params->{"DEBUG"}) {
802 $additional_params->{"DEBUG"} =
803 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
806 if (%main::myconfig) {
807 $::myconfig{jsc_dateformat} = apply {
811 } $::myconfig{"dateformat"};
812 $additional_params->{"myconfig"} ||= \%::myconfig;
813 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
816 $additional_params->{"conf_dbcharset"} = $::lx_office_conf{system}->{dbcharset};
817 $additional_params->{"conf_webdav"} = $::lx_office_conf{features}->{webdav};
818 $additional_params->{"conf_lizenzen"} = $::lx_office_conf{features}->{lizenzen};
819 $additional_params->{"conf_latex_templates"} = $::lx_office_conf{print_templates}->{latex};
820 $additional_params->{"conf_opendocument_templates"} = $::lx_office_conf{print_templates}->{opendocument};
821 $additional_params->{"conf_vertreter"} = $::lx_office_conf{features}->{vertreter};
822 $additional_params->{"conf_show_best_before"} = $::lx_office_conf{features}->{show_best_before};
823 $additional_params->{"conf_parts_image_css"} = $::lx_office_conf{features}->{parts_image_css};
824 $additional_params->{"conf_parts_listing_images"} = $::lx_office_conf{features}->{parts_listing_images};
825 $additional_params->{"conf_parts_show_image"} = $::lx_office_conf{features}->{parts_show_image};
827 if (%main::debug_options) {
828 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
831 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
832 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
833 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
837 $main::lxdebug->leave_sub();
842 sub parse_html_template {
843 $main::lxdebug->enter_sub();
845 my ($self, $file, $additional_params) = @_;
847 $additional_params ||= { };
849 my $real_file = $self->_prepare_html_template($file, $additional_params);
850 my $template = $self->template || $self->init_template;
852 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
855 $template->process($real_file, $additional_params, \$output) || die $template->error;
857 $main::lxdebug->leave_sub();
865 return if $self->template;
867 return $self->template(Template->new({
872 'PLUGIN_BASE' => 'SL::Template::Plugin',
873 'INCLUDE_PATH' => '.:templates/webpages',
874 'COMPILE_EXT' => '.tcc',
875 'COMPILE_DIR' => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
881 $self->{template_object} = shift if @_;
882 return $self->{template_object};
885 sub show_generic_error {
886 $main::lxdebug->enter_sub();
888 my ($self, $error, %params) = @_;
890 if ($self->{__ERROR_HANDLER}) {
891 $self->{__ERROR_HANDLER}->($error);
892 $main::lxdebug->leave_sub();
897 'title_error' => $params{title},
898 'label_error' => $error,
901 if ($params{action}) {
904 map { delete($self->{$_}); } qw(action);
905 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
907 $add_params->{SHOW_BUTTON} = 1;
908 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
909 $add_params->{VARIABLES} = \@vars;
911 } elsif ($params{back_button}) {
912 $add_params->{SHOW_BACK_BUTTON} = 1;
915 $self->{title} = $params{title} if $params{title};
918 print $self->parse_html_template("generic/error", $add_params);
920 print STDERR "Error: $error\n";
922 $main::lxdebug->leave_sub();
927 sub show_generic_information {
928 $main::lxdebug->enter_sub();
930 my ($self, $text, $title) = @_;
933 'title_information' => $title,
934 'label_information' => $text,
937 $self->{title} = $title if ($title);
940 print $self->parse_html_template("generic/information", $add_params);
942 $main::lxdebug->leave_sub();
947 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
948 # changed it to accept an arbitrary number of triggers - sschoeling
950 $main::lxdebug->enter_sub();
953 my $myconfig = shift;
956 # set dateform for jsscript
959 "dd.mm.yy" => "%d.%m.%Y",
960 "dd-mm-yy" => "%d-%m-%Y",
961 "dd/mm/yy" => "%d/%m/%Y",
962 "mm/dd/yy" => "%m/%d/%Y",
963 "mm-dd-yy" => "%m-%d-%Y",
964 "yyyy-mm-dd" => "%Y-%m-%d",
967 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
968 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
975 inputField : "| . (shift) . qq|",
976 ifFormat :"$ifFormat",
977 align : "| . (shift) . qq|",
978 button : "| . (shift) . qq|"
984 <script type="text/javascript">
985 <!--| . join("", @triggers) . qq|//-->
989 $main::lxdebug->leave_sub();
992 } #end sub write_trigger
995 $main::lxdebug->enter_sub();
997 my ($self, $msg) = @_;
999 if (!$self->{callback}) {
1003 print $::form->redirect_header($self->{callback});
1008 $main::lxdebug->leave_sub();
1011 # sort of columns removed - empty sub
1013 $main::lxdebug->enter_sub();
1015 my ($self, @columns) = @_;
1017 $main::lxdebug->leave_sub();
1023 $main::lxdebug->enter_sub(2);
1025 my ($self, $myconfig, $amount, $places, $dash) = @_;
1027 if ($amount eq "") {
1031 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1033 my $neg = ($amount =~ s/^-//);
1034 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1036 if (defined($places) && ($places ne '')) {
1042 my ($actual_places) = ($amount =~ /\.(\d+)/);
1043 $actual_places = length($actual_places);
1044 $places = $actual_places > $places ? $actual_places : $places;
1047 $amount = $self->round_amount($amount, $places);
1050 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1051 my @p = split(/\./, $amount); # split amount at decimal point
1053 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1056 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1059 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1060 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1061 ($neg ? "-$amount" : "$amount" ) ;
1065 $main::lxdebug->leave_sub(2);
1069 sub format_amount_units {
1070 $main::lxdebug->enter_sub();
1075 my $myconfig = \%main::myconfig;
1076 my $amount = $params{amount} * 1;
1077 my $places = $params{places};
1078 my $part_unit_name = $params{part_unit};
1079 my $amount_unit_name = $params{amount_unit};
1080 my $conv_units = $params{conv_units};
1081 my $max_places = $params{max_places};
1083 if (!$part_unit_name) {
1084 $main::lxdebug->leave_sub();
1088 AM->retrieve_all_units();
1089 my $all_units = $main::all_units;
1091 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1092 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1095 if (!scalar @{ $conv_units }) {
1096 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1097 $main::lxdebug->leave_sub();
1101 my $part_unit = $all_units->{$part_unit_name};
1102 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1104 $amount *= $conv_unit->{factor};
1109 foreach my $unit (@$conv_units) {
1110 my $last = $unit->{name} eq $part_unit->{name};
1112 $num = int($amount / $unit->{factor});
1113 $amount -= $num * $unit->{factor};
1116 if ($last ? $amount : $num) {
1117 push @values, { "unit" => $unit->{name},
1118 "amount" => $last ? $amount / $unit->{factor} : $num,
1119 "places" => $last ? $places : 0 };
1126 push @values, { "unit" => $part_unit_name,
1131 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1133 $main::lxdebug->leave_sub();
1139 $main::lxdebug->enter_sub(2);
1144 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1145 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1146 $input =~ s/\#\#/\#/g;
1148 $main::lxdebug->leave_sub(2);
1156 $main::lxdebug->enter_sub(2);
1158 my ($self, $myconfig, $amount) = @_;
1160 if ( ($myconfig->{numberformat} eq '1.000,00')
1161 || ($myconfig->{numberformat} eq '1000,00')) {
1166 if ($myconfig->{numberformat} eq "1'000.00") {
1172 $main::lxdebug->leave_sub(2);
1174 return ($amount * 1);
1178 $main::lxdebug->enter_sub(2);
1180 my ($self, $amount, $places) = @_;
1183 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1185 # Round amounts to eight places before rounding to the requested
1186 # number of places. This gets rid of errors due to internal floating
1187 # point representation.
1188 $amount = $self->round_amount($amount, 8) if $places < 8;
1189 $amount = $amount * (10**($places));
1190 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1192 $main::lxdebug->leave_sub(2);
1194 return $round_amount;
1198 sub parse_template {
1199 $main::lxdebug->enter_sub();
1201 my ($self, $myconfig) = @_;
1206 my $userspath = $::lx_office_conf{paths}->{userspath};
1208 $self->{"cwd"} = getcwd();
1209 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1214 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1215 $template_type = 'OpenDocument';
1216 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1218 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1219 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1220 $template_type = 'LaTeX';
1221 $ext_for_format = 'pdf';
1223 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1224 $template_type = 'HTML';
1225 $ext_for_format = 'html';
1227 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1228 $template_type = 'XML';
1229 $ext_for_format = 'xml';
1231 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1232 $template_type = 'XML';
1234 } elsif ( $self->{"format"} =~ /excel/i ) {
1235 $template_type = 'Excel';
1236 $ext_for_format = 'xls';
1238 } elsif ( defined $self->{'format'}) {
1239 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1241 } elsif ( $self->{'format'} eq '' ) {
1242 $self->error("No Outputformat given: $self->{'format'}");
1244 } else { #Catch the rest
1245 $self->error("Outputformat not defined: $self->{'format'}");
1248 my $template = SL::Template::create(type => $template_type,
1249 file_name => $self->{IN},
1251 myconfig => $myconfig,
1252 userspath => $userspath);
1254 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1255 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1257 if (!$self->{employee_id}) {
1258 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1261 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1262 map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1264 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1266 # OUT is used for the media, screen, printer, email
1267 # for postscript we store a copy in a temporary file
1269 my $prepend_userspath;
1271 if (!$self->{tmpfile}) {
1272 $self->{tmpfile} = "${fileid}.$self->{IN}";
1273 $prepend_userspath = 1;
1276 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1278 $self->{tmpfile} =~ s|.*/||;
1279 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1280 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1282 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1283 $out = $self->{OUT};
1284 $self->{OUT} = ">$self->{tmpfile}";
1290 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1291 $result = $template->parse(*OUT);
1296 $result = $template->parse(*STDOUT);
1301 $self->error("$self->{IN} : " . $template->get_error());
1304 if ($self->{media} eq 'file') {
1305 copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1307 chdir("$self->{cwd}");
1309 $::lxdebug->leave_sub();
1314 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1316 if ($self->{media} eq 'email') {
1318 my $mail = new Mailer;
1320 map { $mail->{$_} = $self->{$_} }
1321 qw(cc bcc subject message version format);
1322 $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1323 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1324 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1325 $mail->{fileid} = "$fileid.";
1326 $myconfig->{signature} =~ s/\r//g;
1328 # if we send html or plain text inline
1329 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1330 $mail->{contenttype} = "text/html";
1332 $mail->{message} =~ s/\r//g;
1333 $mail->{message} =~ s/\n/<br>\n/g;
1334 $myconfig->{signature} =~ s/\n/<br>\n/g;
1335 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1337 open(IN, $self->{tmpfile})
1338 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1340 $mail->{message} .= $_;
1347 if (!$self->{"do_not_attach"}) {
1348 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1349 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1350 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1351 "name" => $attachment_name }];
1354 $mail->{message} =~ s/\r//g;
1355 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1359 my $err = $mail->send();
1360 $self->error($self->cleanup . "$err") if ($err);
1364 $self->{OUT} = $out;
1366 my $numbytes = (-s $self->{tmpfile});
1367 open(IN, $self->{tmpfile})
1368 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1371 $self->{copies} = 1 unless $self->{media} eq 'printer';
1373 chdir("$self->{cwd}");
1374 #print(STDERR "Kopien $self->{copies}\n");
1375 #print(STDERR "OUT $self->{OUT}\n");
1376 for my $i (1 .. $self->{copies}) {
1378 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1379 print OUT while <IN>;
1384 $self->{attachment_filename} = ($self->{attachment_filename})
1385 ? $self->{attachment_filename}
1386 : $self->generate_attachment_filename();
1388 # launch application
1389 print qq|Content-Type: | . $template->get_mime_type() . qq|
1390 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1391 Content-Length: $numbytes
1395 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1406 chdir("$self->{cwd}");
1407 $main::lxdebug->leave_sub();
1410 sub get_formname_translation {
1411 $main::lxdebug->enter_sub();
1412 my ($self, $formname) = @_;
1414 $formname ||= $self->{formname};
1416 my %formname_translations = (
1417 bin_list => $main::locale->text('Bin List'),
1418 credit_note => $main::locale->text('Credit Note'),
1419 invoice => $main::locale->text('Invoice'),
1420 pick_list => $main::locale->text('Pick List'),
1421 proforma => $main::locale->text('Proforma Invoice'),
1422 purchase_order => $main::locale->text('Purchase Order'),
1423 request_quotation => $main::locale->text('RFQ'),
1424 sales_order => $main::locale->text('Confirmation'),
1425 sales_quotation => $main::locale->text('Quotation'),
1426 storno_invoice => $main::locale->text('Storno Invoice'),
1427 sales_delivery_order => $main::locale->text('Delivery Order'),
1428 purchase_delivery_order => $main::locale->text('Delivery Order'),
1429 dunning => $main::locale->text('Dunning'),
1432 $main::lxdebug->leave_sub();
1433 return $formname_translations{$formname}
1436 sub get_number_prefix_for_type {
1437 $main::lxdebug->enter_sub();
1441 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1442 : ($self->{type} =~ /_quotation$/) ? 'quo'
1443 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1446 $main::lxdebug->leave_sub();
1450 sub get_extension_for_format {
1451 $main::lxdebug->enter_sub();
1454 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1455 : $self->{format} =~ /postscript/i ? ".ps"
1456 : $self->{format} =~ /opendocument/i ? ".odt"
1457 : $self->{format} =~ /excel/i ? ".xls"
1458 : $self->{format} =~ /html/i ? ".html"
1461 $main::lxdebug->leave_sub();
1465 sub generate_attachment_filename {
1466 $main::lxdebug->enter_sub();
1469 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1470 my $prefix = $self->get_number_prefix_for_type();
1472 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1473 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1475 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1476 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1479 $attachment_filename = "";
1482 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1483 $attachment_filename =~ s|[\s/\\]+|_|g;
1485 $main::lxdebug->leave_sub();
1486 return $attachment_filename;
1489 sub generate_email_subject {
1490 $main::lxdebug->enter_sub();
1493 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1494 my $prefix = $self->get_number_prefix_for_type();
1496 if ($subject && $self->{"${prefix}number"}) {
1497 $subject .= " " . $self->{"${prefix}number"}
1500 $main::lxdebug->leave_sub();
1505 $main::lxdebug->enter_sub();
1509 chdir("$self->{tmpdir}");
1512 if (-f "$self->{tmpfile}.err") {
1513 open(FH, "$self->{tmpfile}.err");
1518 if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1519 $self->{tmpfile} =~ s|.*/||g;
1521 $self->{tmpfile} =~ s/\.\w+$//g;
1522 my $tmpfile = $self->{tmpfile};
1523 unlink(<$tmpfile.*>);
1526 chdir("$self->{cwd}");
1528 $main::lxdebug->leave_sub();
1534 $main::lxdebug->enter_sub();
1536 my ($self, $date, $myconfig) = @_;
1539 if ($date && $date =~ /\D/) {
1541 if ($myconfig->{dateformat} =~ /^yy/) {
1542 ($yy, $mm, $dd) = split /\D/, $date;
1544 if ($myconfig->{dateformat} =~ /^mm/) {
1545 ($mm, $dd, $yy) = split /\D/, $date;
1547 if ($myconfig->{dateformat} =~ /^dd/) {
1548 ($dd, $mm, $yy) = split /\D/, $date;
1553 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1554 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1556 $dd = "0$dd" if ($dd < 10);
1557 $mm = "0$mm" if ($mm < 10);
1559 $date = "$yy$mm$dd";
1562 $main::lxdebug->leave_sub();
1567 # Database routines used throughout
1569 sub _dbconnect_options {
1571 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1578 $main::lxdebug->enter_sub(2);
1580 my ($self, $myconfig) = @_;
1582 # connect to database
1583 my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1587 if ($myconfig->{dboptions}) {
1588 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1591 $main::lxdebug->leave_sub(2);
1596 sub dbconnect_noauto {
1597 $main::lxdebug->enter_sub();
1599 my ($self, $myconfig) = @_;
1601 # connect to database
1602 my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1606 if ($myconfig->{dboptions}) {
1607 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1610 $main::lxdebug->leave_sub();
1615 sub get_standard_dbh {
1616 $main::lxdebug->enter_sub(2);
1619 my $myconfig = shift || \%::myconfig;
1621 if ($standard_dbh && !$standard_dbh->{Active}) {
1622 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1623 undef $standard_dbh;
1626 $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1628 $main::lxdebug->leave_sub(2);
1630 return $standard_dbh;
1634 $main::lxdebug->enter_sub();
1636 my ($self, $date, $myconfig) = @_;
1637 my $dbh = $self->dbconnect($myconfig);
1639 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1640 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1641 my ($closed) = $sth->fetchrow_array;
1643 $main::lxdebug->leave_sub();
1648 sub update_balance {
1649 $main::lxdebug->enter_sub();
1651 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1653 # if we have a value, go do it
1656 # retrieve balance from table
1657 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1658 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1659 my ($balance) = $sth->fetchrow_array;
1665 $query = "UPDATE $table SET $field = $balance WHERE $where";
1666 do_query($self, $dbh, $query, @values);
1668 $main::lxdebug->leave_sub();
1671 sub update_exchangerate {
1672 $main::lxdebug->enter_sub();
1674 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1676 # some sanity check for currency
1678 $main::lxdebug->leave_sub();
1681 $query = qq|SELECT curr FROM defaults|;
1683 my ($currency) = selectrow_query($self, $dbh, $query);
1684 my ($defaultcurrency) = split m/:/, $currency;
1687 if ($curr eq $defaultcurrency) {
1688 $main::lxdebug->leave_sub();
1692 $query = qq|SELECT e.curr FROM exchangerate e
1693 WHERE e.curr = ? AND e.transdate = ?
1695 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1704 $buy = conv_i($buy, "NULL");
1705 $sell = conv_i($sell, "NULL");
1708 if ($buy != 0 && $sell != 0) {
1709 $set = "buy = $buy, sell = $sell";
1710 } elsif ($buy != 0) {
1711 $set = "buy = $buy";
1712 } elsif ($sell != 0) {
1713 $set = "sell = $sell";
1716 if ($sth->fetchrow_array) {
1717 $query = qq|UPDATE exchangerate
1723 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1724 VALUES (?, $buy, $sell, ?)|;
1727 do_query($self, $dbh, $query, $curr, $transdate);
1729 $main::lxdebug->leave_sub();
1732 sub save_exchangerate {
1733 $main::lxdebug->enter_sub();
1735 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1737 my $dbh = $self->dbconnect($myconfig);
1741 $buy = $rate if $fld eq 'buy';
1742 $sell = $rate if $fld eq 'sell';
1745 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1750 $main::lxdebug->leave_sub();
1753 sub get_exchangerate {
1754 $main::lxdebug->enter_sub();
1756 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1759 unless ($transdate) {
1760 $main::lxdebug->leave_sub();
1764 $query = qq|SELECT curr FROM defaults|;
1766 my ($currency) = selectrow_query($self, $dbh, $query);
1767 my ($defaultcurrency) = split m/:/, $currency;
1769 if ($currency eq $defaultcurrency) {
1770 $main::lxdebug->leave_sub();
1774 $query = qq|SELECT e.$fld FROM exchangerate e
1775 WHERE e.curr = ? AND e.transdate = ?|;
1776 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1780 $main::lxdebug->leave_sub();
1782 return $exchangerate;
1785 sub check_exchangerate {
1786 $main::lxdebug->enter_sub();
1788 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1790 if ($fld !~/^buy|sell$/) {
1791 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1794 unless ($transdate) {
1795 $main::lxdebug->leave_sub();
1799 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1801 if ($currency eq $defaultcurrency) {
1802 $main::lxdebug->leave_sub();
1806 my $dbh = $self->get_standard_dbh($myconfig);
1807 my $query = qq|SELECT e.$fld FROM exchangerate e
1808 WHERE e.curr = ? AND e.transdate = ?|;
1810 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1812 $main::lxdebug->leave_sub();
1814 return $exchangerate;
1817 sub get_all_currencies {
1818 $main::lxdebug->enter_sub();
1821 my $myconfig = shift || \%::myconfig;
1822 my $dbh = $self->get_standard_dbh($myconfig);
1824 my $query = qq|SELECT curr FROM defaults|;
1826 my ($curr) = selectrow_query($self, $dbh, $query);
1827 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1829 $main::lxdebug->leave_sub();
1834 sub get_default_currency {
1835 $main::lxdebug->enter_sub();
1837 my ($self, $myconfig) = @_;
1838 my @currencies = $self->get_all_currencies($myconfig);
1840 $main::lxdebug->leave_sub();
1842 return $currencies[0];
1845 sub set_payment_options {
1846 $main::lxdebug->enter_sub();
1848 my ($self, $myconfig, $transdate) = @_;
1850 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1852 my $dbh = $self->get_standard_dbh($myconfig);
1855 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1856 qq|FROM payment_terms p | .
1859 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1860 $self->{payment_terms}) =
1861 selectrow_query($self, $dbh, $query, $self->{payment_id});
1863 if ($transdate eq "") {
1864 if ($self->{invdate}) {
1865 $transdate = $self->{invdate};
1867 $transdate = $self->{transdate};
1872 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1873 qq|FROM payment_terms|;
1874 ($self->{netto_date}, $self->{skonto_date}) =
1875 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1877 my ($invtotal, $total);
1878 my (%amounts, %formatted_amounts);
1880 if ($self->{type} =~ /_order$/) {
1881 $amounts{invtotal} = $self->{ordtotal};
1882 $amounts{total} = $self->{ordtotal};
1884 } elsif ($self->{type} =~ /_quotation$/) {
1885 $amounts{invtotal} = $self->{quototal};
1886 $amounts{total} = $self->{quototal};
1889 $amounts{invtotal} = $self->{invtotal};
1890 $amounts{total} = $self->{total};
1892 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1894 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1896 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1897 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1898 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1900 foreach (keys %amounts) {
1901 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1902 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1905 if ($self->{"language_id"}) {
1907 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1908 qq|FROM translation_payment_terms t | .
1909 qq|LEFT JOIN language l ON t.language_id = l.id | .
1910 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1911 my ($description_long, $output_numberformat, $output_dateformat,
1912 $output_longdates) =
1913 selectrow_query($self, $dbh, $query,
1914 $self->{"language_id"}, $self->{"payment_id"});
1916 $self->{payment_terms} = $description_long if ($description_long);
1918 if ($output_dateformat) {
1919 foreach my $key (qw(netto_date skonto_date)) {
1921 $main::locale->reformat_date($myconfig, $self->{$key},
1927 if ($output_numberformat &&
1928 ($output_numberformat ne $myconfig->{"numberformat"})) {
1929 my $saved_numberformat = $myconfig->{"numberformat"};
1930 $myconfig->{"numberformat"} = $output_numberformat;
1931 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1932 $myconfig->{"numberformat"} = $saved_numberformat;
1936 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1937 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1938 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1939 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1940 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1941 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1942 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1944 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1946 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1948 $main::lxdebug->leave_sub();
1952 sub get_template_language {
1953 $main::lxdebug->enter_sub();
1955 my ($self, $myconfig) = @_;
1957 my $template_code = "";
1959 if ($self->{language_id}) {
1960 my $dbh = $self->get_standard_dbh($myconfig);
1961 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1962 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1965 $main::lxdebug->leave_sub();
1967 return $template_code;
1970 sub get_printer_code {
1971 $main::lxdebug->enter_sub();
1973 my ($self, $myconfig) = @_;
1975 my $template_code = "";
1977 if ($self->{printer_id}) {
1978 my $dbh = $self->get_standard_dbh($myconfig);
1979 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1980 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1983 $main::lxdebug->leave_sub();
1985 return $template_code;
1989 $main::lxdebug->enter_sub();
1991 my ($self, $myconfig) = @_;
1993 my $template_code = "";
1995 if ($self->{shipto_id}) {
1996 my $dbh = $self->get_standard_dbh($myconfig);
1997 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1998 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1999 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
2002 $main::lxdebug->leave_sub();
2006 $main::lxdebug->enter_sub();
2008 my ($self, $dbh, $id, $module) = @_;
2013 foreach my $item (qw(name department_1 department_2 street zipcode city country
2014 contact cp_gender phone fax email)) {
2015 if ($self->{"shipto$item"}) {
2016 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2018 push(@values, $self->{"shipto${item}"});
2022 if ($self->{shipto_id}) {
2023 my $query = qq|UPDATE shipto set
2025 shiptodepartment_1 = ?,
2026 shiptodepartment_2 = ?,
2032 shiptocp_gender = ?,
2036 WHERE shipto_id = ?|;
2037 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2039 my $query = qq|SELECT * FROM shipto
2040 WHERE shiptoname = ? AND
2041 shiptodepartment_1 = ? AND
2042 shiptodepartment_2 = ? AND
2043 shiptostreet = ? AND
2044 shiptozipcode = ? AND
2046 shiptocountry = ? AND
2047 shiptocontact = ? AND
2048 shiptocp_gender = ? AND
2054 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2057 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2058 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2059 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2060 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2061 do_query($self, $dbh, $query, $id, @values, $module);
2066 $main::lxdebug->leave_sub();
2070 $main::lxdebug->enter_sub();
2072 my ($self, $dbh) = @_;
2074 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2076 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2077 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2078 $self->{"employee_id"} *= 1;
2080 $main::lxdebug->leave_sub();
2083 sub get_employee_data {
2084 $main::lxdebug->enter_sub();
2089 Common::check_params(\%params, qw(prefix));
2090 Common::check_params_x(\%params, qw(id));
2093 $main::lxdebug->leave_sub();
2097 my $myconfig = \%main::myconfig;
2098 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2100 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2103 my $user = User->new($login);
2104 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2106 $self->{$params{prefix} . '_login'} = $login;
2107 $self->{$params{prefix} . '_name'} ||= $login;
2110 $main::lxdebug->leave_sub();
2114 $main::lxdebug->enter_sub();
2116 my ($self, $myconfig, $reference_date) = @_;
2118 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2120 my $dbh = $self->get_standard_dbh($myconfig);
2121 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2122 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2124 $main::lxdebug->leave_sub();
2130 $main::lxdebug->enter_sub();
2132 my ($self, $dbh, $id, $key) = @_;
2134 $key = "all_contacts" unless ($key);
2138 $main::lxdebug->leave_sub();
2143 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2144 qq|FROM contacts | .
2145 qq|WHERE cp_cv_id = ? | .
2146 qq|ORDER BY lower(cp_name)|;
2148 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2150 $main::lxdebug->leave_sub();
2154 $main::lxdebug->enter_sub();
2156 my ($self, $dbh, $key) = @_;
2158 my ($all, $old_id, $where, @values);
2160 if (ref($key) eq "HASH") {
2163 $key = "ALL_PROJECTS";
2165 foreach my $p (keys(%{$params})) {
2167 $all = $params->{$p};
2168 } elsif ($p eq "old_id") {
2169 $old_id = $params->{$p};
2170 } elsif ($p eq "key") {
2171 $key = $params->{$p};
2177 $where = "WHERE active ";
2179 if (ref($old_id) eq "ARRAY") {
2180 my @ids = grep({ $_ } @{$old_id});
2182 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2183 push(@values, @ids);
2186 $where .= " OR (id = ?) ";
2187 push(@values, $old_id);
2193 qq|SELECT id, projectnumber, description, active | .
2196 qq|ORDER BY lower(projectnumber)|;
2198 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2200 $main::lxdebug->leave_sub();
2204 $main::lxdebug->enter_sub();
2206 my ($self, $dbh, $vc_id, $key) = @_;
2208 $key = "all_shipto" unless ($key);
2211 # get shipping addresses
2212 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2214 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2220 $main::lxdebug->leave_sub();
2224 $main::lxdebug->enter_sub();
2226 my ($self, $dbh, $key) = @_;
2228 $key = "all_printers" unless ($key);
2230 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2232 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2234 $main::lxdebug->leave_sub();
2238 $main::lxdebug->enter_sub();
2240 my ($self, $dbh, $params) = @_;
2243 $key = $params->{key};
2244 $key = "all_charts" unless ($key);
2246 my $transdate = quote_db_date($params->{transdate});
2249 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2251 qq|LEFT JOIN taxkeys tk ON | .
2252 qq|(tk.id = (SELECT id FROM taxkeys | .
2253 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2254 qq| ORDER BY startdate DESC LIMIT 1)) | .
2255 qq|ORDER BY c.accno|;
2257 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2259 $main::lxdebug->leave_sub();
2262 sub _get_taxcharts {
2263 $main::lxdebug->enter_sub();
2265 my ($self, $dbh, $params) = @_;
2267 my $key = "all_taxcharts";
2270 if (ref $params eq 'HASH') {
2271 $key = $params->{key} if ($params->{key});
2272 if ($params->{module} eq 'AR') {
2273 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2275 } elsif ($params->{module} eq 'AP') {
2276 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2283 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2285 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2287 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2289 $main::lxdebug->leave_sub();
2293 $main::lxdebug->enter_sub();
2295 my ($self, $dbh, $key) = @_;
2297 $key = "all_taxzones" unless ($key);
2299 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2301 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2303 $main::lxdebug->leave_sub();
2306 sub _get_employees {
2307 $main::lxdebug->enter_sub();
2309 my ($self, $dbh, $default_key, $key) = @_;
2311 $key = $default_key unless ($key);
2312 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2314 $main::lxdebug->leave_sub();
2317 sub _get_business_types {
2318 $main::lxdebug->enter_sub();
2320 my ($self, $dbh, $key) = @_;
2322 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2323 $options->{key} ||= "all_business_types";
2326 if (exists $options->{salesman}) {
2327 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2330 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2332 $main::lxdebug->leave_sub();
2335 sub _get_languages {
2336 $main::lxdebug->enter_sub();
2338 my ($self, $dbh, $key) = @_;
2340 $key = "all_languages" unless ($key);
2342 my $query = qq|SELECT * FROM language ORDER BY id|;
2344 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2346 $main::lxdebug->leave_sub();
2349 sub _get_dunning_configs {
2350 $main::lxdebug->enter_sub();
2352 my ($self, $dbh, $key) = @_;
2354 $key = "all_dunning_configs" unless ($key);
2356 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2358 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2360 $main::lxdebug->leave_sub();
2363 sub _get_currencies {
2364 $main::lxdebug->enter_sub();
2366 my ($self, $dbh, $key) = @_;
2368 $key = "all_currencies" unless ($key);
2370 my $query = qq|SELECT curr AS currency FROM defaults|;
2372 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2374 $main::lxdebug->leave_sub();
2378 $main::lxdebug->enter_sub();
2380 my ($self, $dbh, $key) = @_;
2382 $key = "all_payments" unless ($key);
2384 my $query = qq|SELECT * FROM payment_terms ORDER BY sortkey|;
2386 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2388 $main::lxdebug->leave_sub();
2391 sub _get_customers {
2392 $main::lxdebug->enter_sub();
2394 my ($self, $dbh, $key) = @_;
2396 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2397 $options->{key} ||= "all_customers";
2398 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2401 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2402 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2403 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2405 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2406 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2408 $main::lxdebug->leave_sub();
2412 $main::lxdebug->enter_sub();
2414 my ($self, $dbh, $key) = @_;
2416 $key = "all_vendors" unless ($key);
2418 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2420 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2422 $main::lxdebug->leave_sub();
2425 sub _get_departments {
2426 $main::lxdebug->enter_sub();
2428 my ($self, $dbh, $key) = @_;
2430 $key = "all_departments" unless ($key);
2432 my $query = qq|SELECT * FROM department ORDER BY description|;
2434 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2436 $main::lxdebug->leave_sub();
2439 sub _get_warehouses {
2440 $main::lxdebug->enter_sub();
2442 my ($self, $dbh, $param) = @_;
2444 my ($key, $bins_key);
2446 if ('' eq ref $param) {
2450 $key = $param->{key};
2451 $bins_key = $param->{bins};
2454 my $query = qq|SELECT w.* FROM warehouse w
2455 WHERE (NOT w.invalid) AND
2456 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2457 ORDER BY w.sortkey|;
2459 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2462 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?
2463 ORDER BY description|;
2464 my $sth = prepare_query($self, $dbh, $query);
2466 foreach my $warehouse (@{ $self->{$key} }) {
2467 do_statement($self, $sth, $query, $warehouse->{id});
2468 $warehouse->{$bins_key} = [];
2470 while (my $ref = $sth->fetchrow_hashref()) {
2471 push @{ $warehouse->{$bins_key} }, $ref;
2477 $main::lxdebug->leave_sub();
2481 $main::lxdebug->enter_sub();
2483 my ($self, $dbh, $table, $key, $sortkey) = @_;
2485 my $query = qq|SELECT * FROM $table|;
2486 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2488 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2490 $main::lxdebug->leave_sub();
2494 # $main::lxdebug->enter_sub();
2496 # my ($self, $dbh, $key) = @_;
2498 # $key ||= "all_groups";
2500 # my $groups = $main::auth->read_groups();
2502 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2504 # $main::lxdebug->leave_sub();
2508 $main::lxdebug->enter_sub();
2513 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2514 my ($sth, $query, $ref);
2516 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2517 my $vc_id = $self->{"${vc}_id"};
2519 if ($params{"contacts"}) {
2520 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2523 if ($params{"shipto"}) {
2524 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2527 if ($params{"projects"} || $params{"all_projects"}) {
2528 $self->_get_projects($dbh, $params{"all_projects"} ?
2529 $params{"all_projects"} : $params{"projects"},
2530 $params{"all_projects"} ? 1 : 0);
2533 if ($params{"printers"}) {
2534 $self->_get_printers($dbh, $params{"printers"});
2537 if ($params{"languages"}) {
2538 $self->_get_languages($dbh, $params{"languages"});
2541 if ($params{"charts"}) {
2542 $self->_get_charts($dbh, $params{"charts"});
2545 if ($params{"taxcharts"}) {
2546 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2549 if ($params{"taxzones"}) {
2550 $self->_get_taxzones($dbh, $params{"taxzones"});
2553 if ($params{"employees"}) {
2554 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2557 if ($params{"salesmen"}) {
2558 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2561 if ($params{"business_types"}) {
2562 $self->_get_business_types($dbh, $params{"business_types"});
2565 if ($params{"dunning_configs"}) {
2566 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2569 if($params{"currencies"}) {
2570 $self->_get_currencies($dbh, $params{"currencies"});
2573 if($params{"customers"}) {
2574 $self->_get_customers($dbh, $params{"customers"});
2577 if($params{"vendors"}) {
2578 if (ref $params{"vendors"} eq 'HASH') {
2579 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2581 $self->_get_vendors($dbh, $params{"vendors"});
2585 if($params{"payments"}) {
2586 $self->_get_payments($dbh, $params{"payments"});
2589 if($params{"departments"}) {
2590 $self->_get_departments($dbh, $params{"departments"});
2593 if ($params{price_factors}) {
2594 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2597 if ($params{warehouses}) {
2598 $self->_get_warehouses($dbh, $params{warehouses});
2601 # if ($params{groups}) {
2602 # $self->_get_groups($dbh, $params{groups});
2605 if ($params{partsgroup}) {
2606 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2609 $main::lxdebug->leave_sub();
2612 # this sub gets the id and name from $table
2614 $main::lxdebug->enter_sub();
2616 my ($self, $myconfig, $table) = @_;
2618 # connect to database
2619 my $dbh = $self->get_standard_dbh($myconfig);
2621 $table = $table eq "customer" ? "customer" : "vendor";
2622 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2624 my ($query, @values);
2626 if (!$self->{openinvoices}) {
2628 if ($self->{customernumber} ne "") {
2629 $where = qq|(vc.customernumber ILIKE ?)|;
2630 push(@values, '%' . $self->{customernumber} . '%');
2632 $where = qq|(vc.name ILIKE ?)|;
2633 push(@values, '%' . $self->{$table} . '%');
2637 qq~SELECT vc.id, vc.name,
2638 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2640 WHERE $where AND (NOT vc.obsolete)
2644 qq~SELECT DISTINCT vc.id, vc.name,
2645 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2647 JOIN $table vc ON (a.${table}_id = vc.id)
2648 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2650 push(@values, '%' . $self->{$table} . '%');
2653 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2655 $main::lxdebug->leave_sub();
2657 return scalar(@{ $self->{name_list} });
2660 # the selection sub is used in the AR, AP, IS, IR and OE module
2663 $main::lxdebug->enter_sub();
2665 my ($self, $myconfig, $table, $module) = @_;
2668 my $dbh = $self->get_standard_dbh;
2670 $table = $table eq "customer" ? "customer" : "vendor";
2672 my $query = qq|SELECT count(*) FROM $table|;
2673 my ($count) = selectrow_query($self, $dbh, $query);
2675 # build selection list
2676 if ($count <= $myconfig->{vclimit}) {
2677 $query = qq|SELECT id, name, salesman_id
2678 FROM $table WHERE NOT obsolete
2680 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2684 $self->get_employee($dbh);
2686 # setup sales contacts
2687 $query = qq|SELECT e.id, e.name
2689 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2690 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2693 push(@{ $self->{all_employees} },
2694 { id => $self->{employee_id},
2695 name => $self->{employee} });
2697 # sort the whole thing
2698 @{ $self->{all_employees} } =
2699 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2701 if ($module eq 'AR') {
2703 # prepare query for departments
2704 $query = qq|SELECT id, description
2707 ORDER BY description|;
2710 $query = qq|SELECT id, description
2712 ORDER BY description|;
2715 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2718 $query = qq|SELECT id, description
2722 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2725 $query = qq|SELECT printer_description, id
2727 ORDER BY printer_description|;
2729 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2732 $query = qq|SELECT id, description
2736 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2738 $main::lxdebug->leave_sub();
2741 sub language_payment {
2742 $main::lxdebug->enter_sub();
2744 my ($self, $myconfig) = @_;
2746 my $dbh = $self->get_standard_dbh($myconfig);
2748 my $query = qq|SELECT id, description
2752 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2755 $query = qq|SELECT printer_description, id
2757 ORDER BY printer_description|;
2759 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2762 $query = qq|SELECT id, description
2766 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2768 # get buchungsgruppen
2769 $query = qq|SELECT id, description
2770 FROM buchungsgruppen|;
2772 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2774 $main::lxdebug->leave_sub();
2777 # this is only used for reports
2778 sub all_departments {
2779 $main::lxdebug->enter_sub();
2781 my ($self, $myconfig, $table) = @_;
2783 my $dbh = $self->get_standard_dbh($myconfig);
2786 if ($table eq 'customer') {
2787 $where = "WHERE role = 'P' ";
2790 my $query = qq|SELECT id, description
2793 ORDER BY description|;
2794 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2796 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2798 $main::lxdebug->leave_sub();
2802 $main::lxdebug->enter_sub();
2804 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2807 if ($table eq "customer") {
2816 $self->all_vc($myconfig, $table, $module);
2818 # get last customers or vendors
2819 my ($query, $sth, $ref);
2821 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2826 my $transdate = "current_date";
2827 if ($self->{transdate}) {
2828 $transdate = $dbh->quote($self->{transdate});
2831 # now get the account numbers
2832 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2833 FROM chart c, taxkeys tk
2834 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2835 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2838 $sth = $dbh->prepare($query);
2840 do_statement($self, $sth, $query, '%' . $module . '%');
2842 $self->{accounts} = "";
2843 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2845 foreach my $key (split(/:/, $ref->{link})) {
2846 if ($key =~ /\Q$module\E/) {
2848 # cross reference for keys
2849 $xkeyref{ $ref->{accno} } = $key;
2851 push @{ $self->{"${module}_links"}{$key} },
2852 { accno => $ref->{accno},
2853 description => $ref->{description},
2854 taxkey => $ref->{taxkey_id},
2855 tax_id => $ref->{tax_id} };
2857 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2863 # get taxkeys and description
2864 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2865 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2867 if (($module eq "AP") || ($module eq "AR")) {
2868 # get tax rates and description
2869 $query = qq|SELECT * FROM tax|;
2870 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2876 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2877 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2878 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2879 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2881 d.description AS department,
2884 JOIN $table c ON (a.${table}_id = c.id)
2885 LEFT JOIN employee e ON (e.id = a.employee_id)
2886 LEFT JOIN department d ON (d.id = a.department_id)
2888 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2890 foreach my $key (keys %$ref) {
2891 $self->{$key} = $ref->{$key};
2894 my $transdate = "current_date";
2895 if ($self->{transdate}) {
2896 $transdate = $dbh->quote($self->{transdate});
2899 # now get the account numbers
2900 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2902 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2904 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2905 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2908 $sth = $dbh->prepare($query);
2909 do_statement($self, $sth, $query, "%$module%");
2911 $self->{accounts} = "";
2912 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2914 foreach my $key (split(/:/, $ref->{link})) {
2915 if ($key =~ /\Q$module\E/) {
2917 # cross reference for keys
2918 $xkeyref{ $ref->{accno} } = $key;
2920 push @{ $self->{"${module}_links"}{$key} },
2921 { accno => $ref->{accno},
2922 description => $ref->{description},
2923 taxkey => $ref->{taxkey_id},
2924 tax_id => $ref->{tax_id} };
2926 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2932 # get amounts from individual entries
2935 c.accno, c.description,
2936 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2940 LEFT JOIN chart c ON (c.id = a.chart_id)
2941 LEFT JOIN project p ON (p.id = a.project_id)
2942 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2943 WHERE (tk.taxkey_id=a.taxkey) AND
2944 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2945 THEN tk.chart_id = a.chart_id
2948 OR (c.link='%tax%')) AND
2949 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2950 WHERE a.trans_id = ?
2951 AND a.fx_transaction = '0'
2952 ORDER BY a.acc_trans_id, a.transdate|;
2953 $sth = $dbh->prepare($query);
2954 do_statement($self, $sth, $query, $self->{id});
2956 # get exchangerate for currency
2957 $self->{exchangerate} =
2958 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2961 # store amounts in {acc_trans}{$key} for multiple accounts
2962 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2963 $ref->{exchangerate} =
2964 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2965 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2968 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2969 $ref->{amount} *= -1;
2971 $ref->{index} = $index;
2973 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2979 d.curr AS currencies, d.closedto, d.revtrans,
2980 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2981 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2983 $ref = selectfirst_hashref_query($self, $dbh, $query);
2984 map { $self->{$_} = $ref->{$_} } keys %$ref;
2991 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2992 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2993 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2995 $ref = selectfirst_hashref_query($self, $dbh, $query);
2996 map { $self->{$_} = $ref->{$_} } keys %$ref;
2998 if ($self->{"$self->{vc}_id"}) {
3000 # only setup currency
3001 ($self->{currency}) = split(/:/, $self->{currencies});
3005 $self->lastname_used($dbh, $myconfig, $table, $module);
3007 # get exchangerate for currency
3008 $self->{exchangerate} =
3009 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3015 $main::lxdebug->leave_sub();
3019 $main::lxdebug->enter_sub();
3021 my ($self, $dbh, $myconfig, $table, $module) = @_;
3025 $table = $table eq "customer" ? "customer" : "vendor";
3026 my %column_map = ("a.curr" => "currency",
3027 "a.${table}_id" => "${table}_id",
3028 "a.department_id" => "department_id",
3029 "d.description" => "department",
3030 "ct.name" => $table,
3031 "current_date + ct.terms" => "duedate",
3034 if ($self->{type} =~ /delivery_order/) {
3035 $arap = 'delivery_orders';
3036 delete $column_map{"a.curr"};
3038 } elsif ($self->{type} =~ /_order/) {
3040 $where = "quotation = '0'";
3042 } elsif ($self->{type} =~ /_quotation/) {
3044 $where = "quotation = '1'";
3046 } elsif ($table eq 'customer') {
3054 $where = "($where) AND" if ($where);
3055 my $query = qq|SELECT MAX(id) FROM $arap
3056 WHERE $where ${table}_id > 0|;
3057 my ($trans_id) = selectrow_query($self, $dbh, $query);
3060 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3061 $query = qq|SELECT $column_spec
3063 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3064 LEFT JOIN department d ON (a.department_id = d.id)
3066 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3068 map { $self->{$_} = $ref->{$_} } values %column_map;
3070 $main::lxdebug->leave_sub();
3074 $main::lxdebug->enter_sub();
3077 my $myconfig = shift || \%::myconfig;
3078 my ($thisdate, $days) = @_;
3080 my $dbh = $self->get_standard_dbh($myconfig);
3085 my $dateformat = $myconfig->{dateformat};
3086 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3087 $thisdate = $dbh->quote($thisdate);
3088 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3090 $query = qq|SELECT current_date AS thisdate|;
3093 ($thisdate) = selectrow_query($self, $dbh, $query);
3095 $main::lxdebug->leave_sub();
3101 $main::lxdebug->enter_sub();
3103 my ($self, $string) = @_;
3105 if ($string !~ /%/) {
3106 $string = "%$string%";
3109 $string =~ s/\'/\'\'/g;
3111 $main::lxdebug->leave_sub();
3117 $main::lxdebug->enter_sub();
3119 my ($self, $flds, $new, $count, $numrows) = @_;
3123 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3128 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3130 my $j = $item->{ndx} - 1;
3131 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3135 for $i ($count + 1 .. $numrows) {
3136 map { delete $self->{"${_}_$i"} } @{$flds};
3139 $main::lxdebug->leave_sub();
3143 $main::lxdebug->enter_sub();
3145 my ($self, $myconfig) = @_;
3149 my $dbh = $self->dbconnect_noauto($myconfig);
3151 my $query = qq|DELETE FROM status
3152 WHERE (formname = ?) AND (trans_id = ?)|;
3153 my $sth = prepare_query($self, $dbh, $query);
3155 if ($self->{formname} =~ /(check|receipt)/) {
3156 for $i (1 .. $self->{rowcount}) {
3157 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3160 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3164 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3165 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3167 my %queued = split / /, $self->{queued};
3170 if ($self->{formname} =~ /(check|receipt)/) {
3172 # this is a check or receipt, add one entry for each lineitem
3173 my ($accno) = split /--/, $self->{account};
3174 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3175 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3176 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3177 $sth = prepare_query($self, $dbh, $query);
3179 for $i (1 .. $self->{rowcount}) {
3180 if ($self->{"checked_$i"}) {
3181 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3187 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3188 VALUES (?, ?, ?, ?, ?)|;
3189 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3190 $queued{$self->{formname}}, $self->{formname});
3196 $main::lxdebug->leave_sub();
3200 $main::lxdebug->enter_sub();
3202 my ($self, $dbh) = @_;
3204 my ($query, $printed, $emailed);
3206 my $formnames = $self->{printed};
3207 my $emailforms = $self->{emailed};
3209 $query = qq|DELETE FROM status
3210 WHERE (formname = ?) AND (trans_id = ?)|;
3211 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3213 # this only applies to the forms
3214 # checks and receipts are posted when printed or queued
3216 if ($self->{queued}) {
3217 my %queued = split / /, $self->{queued};
3219 foreach my $formname (keys %queued) {
3220 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3221 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3223 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3224 VALUES (?, ?, ?, ?, ?)|;
3225 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3227 $formnames =~ s/\Q$self->{formname}\E//;
3228 $emailforms =~ s/\Q$self->{formname}\E//;
3233 # save printed, emailed info
3234 $formnames =~ s/^ +//g;
3235 $emailforms =~ s/^ +//g;
3238 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3239 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3241 foreach my $formname (keys %status) {
3242 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3243 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3245 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3246 VALUES (?, ?, ?, ?)|;
3247 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3250 $main::lxdebug->leave_sub();
3254 # $main::locale->text('SAVED')
3255 # $main::locale->text('DELETED')
3256 # $main::locale->text('ADDED')
3257 # $main::locale->text('PAYMENT POSTED')
3258 # $main::locale->text('POSTED')
3259 # $main::locale->text('POSTED AS NEW')
3260 # $main::locale->text('ELSE')
3261 # $main::locale->text('SAVED FOR DUNNING')
3262 # $main::locale->text('DUNNING STARTED')
3263 # $main::locale->text('PRINTED')
3264 # $main::locale->text('MAILED')
3265 # $main::locale->text('SCREENED')
3266 # $main::locale->text('CANCELED')
3267 # $main::locale->text('invoice')
3268 # $main::locale->text('proforma')
3269 # $main::locale->text('sales_order')
3270 # $main::locale->text('pick_list')
3271 # $main::locale->text('purchase_order')
3272 # $main::locale->text('bin_list')
3273 # $main::locale->text('sales_quotation')
3274 # $main::locale->text('request_quotation')
3277 $main::lxdebug->enter_sub();
3280 my $dbh = shift || $self->get_standard_dbh;
3282 if(!exists $self->{employee_id}) {
3283 &get_employee($self, $dbh);
3287 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3288 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3289 my @values = (conv_i($self->{id}), $self->{login},
3290 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3291 do_query($self, $dbh, $query, @values);
3295 $main::lxdebug->leave_sub();
3299 $main::lxdebug->enter_sub();
3301 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3302 my ($orderBy, $desc) = split(/\-\-/, $order);
3303 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3306 if ($trans_id ne "") {
3308 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 | .
3309 qq|FROM history_erp h | .
3310 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3311 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3314 my $sth = $dbh->prepare($query) || $self->dberror($query);
3316 $sth->execute() || $self->dberror("$query");
3318 while(my $hash_ref = $sth->fetchrow_hashref()) {
3319 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3320 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3321 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3322 $tempArray[$i++] = $hash_ref;
3324 $main::lxdebug->leave_sub() and return \@tempArray
3325 if ($i > 0 && $tempArray[0] ne "");
3327 $main::lxdebug->leave_sub();
3331 sub update_defaults {
3332 $main::lxdebug->enter_sub();
3334 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3337 if ($provided_dbh) {
3338 $dbh = $provided_dbh;
3340 $dbh = $self->dbconnect_noauto($myconfig);
3342 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3343 my $sth = $dbh->prepare($query);
3345 $sth->execute || $self->dberror($query);
3346 my ($var) = $sth->fetchrow_array;
3349 if ($var =~ m/\d+$/) {
3350 my $new_var = (substr $var, $-[0]) * 1 + 1;
3351 my $len_diff = length($var) - $-[0] - length($new_var);
3352 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3358 $query = qq|UPDATE defaults SET $fld = ?|;
3359 do_query($self, $dbh, $query, $var);
3361 if (!$provided_dbh) {
3366 $main::lxdebug->leave_sub();
3371 sub update_business {
3372 $main::lxdebug->enter_sub();
3374 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3377 if ($provided_dbh) {
3378 $dbh = $provided_dbh;
3380 $dbh = $self->dbconnect_noauto($myconfig);
3383 qq|SELECT customernumberinit FROM business
3384 WHERE id = ? FOR UPDATE|;
3385 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3387 return undef unless $var;
3389 if ($var =~ m/\d+$/) {
3390 my $new_var = (substr $var, $-[0]) * 1 + 1;
3391 my $len_diff = length($var) - $-[0] - length($new_var);
3392 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3398 $query = qq|UPDATE business
3399 SET customernumberinit = ?
3401 do_query($self, $dbh, $query, $var, $business_id);
3403 if (!$provided_dbh) {
3408 $main::lxdebug->leave_sub();
3413 sub get_partsgroup {
3414 $main::lxdebug->enter_sub();
3416 my ($self, $myconfig, $p) = @_;
3417 my $target = $p->{target} || 'all_partsgroup';
3419 my $dbh = $self->get_standard_dbh($myconfig);
3421 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3423 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3426 if ($p->{searchitems} eq 'part') {
3427 $query .= qq|WHERE p.inventory_accno_id > 0|;
3429 if ($p->{searchitems} eq 'service') {
3430 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3432 if ($p->{searchitems} eq 'assembly') {
3433 $query .= qq|WHERE p.assembly = '1'|;
3435 if ($p->{searchitems} eq 'labor') {
3436 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3439 $query .= qq|ORDER BY partsgroup|;
3442 $query = qq|SELECT id, partsgroup FROM partsgroup
3443 ORDER BY partsgroup|;
3446 if ($p->{language_code}) {
3447 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3448 t.description AS translation
3450 JOIN parts p ON (p.partsgroup_id = pg.id)
3451 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3452 ORDER BY translation|;
3453 @values = ($p->{language_code});
3456 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3458 $main::lxdebug->leave_sub();
3461 sub get_pricegroup {
3462 $main::lxdebug->enter_sub();
3464 my ($self, $myconfig, $p) = @_;
3466 my $dbh = $self->get_standard_dbh($myconfig);
3468 my $query = qq|SELECT p.id, p.pricegroup
3471 $query .= qq| ORDER BY pricegroup|;
3474 $query = qq|SELECT id, pricegroup FROM pricegroup
3475 ORDER BY pricegroup|;
3478 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3480 $main::lxdebug->leave_sub();
3484 # usage $form->all_years($myconfig, [$dbh])
3485 # return list of all years where bookings found
3488 $main::lxdebug->enter_sub();
3490 my ($self, $myconfig, $dbh) = @_;
3492 $dbh ||= $self->get_standard_dbh($myconfig);
3495 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3496 (SELECT MAX(transdate) FROM acc_trans)|;
3497 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3499 if ($myconfig->{dateformat} =~ /^yy/) {
3500 ($startdate) = split /\W/, $startdate;
3501 ($enddate) = split /\W/, $enddate;
3503 (@_) = split /\W/, $startdate;
3505 (@_) = split /\W/, $enddate;
3510 $startdate = substr($startdate,0,4);
3511 $enddate = substr($enddate,0,4);
3513 while ($enddate >= $startdate) {
3514 push @all_years, $enddate--;
3519 $main::lxdebug->leave_sub();
3523 $main::lxdebug->enter_sub();
3527 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3529 $main::lxdebug->leave_sub();
3533 $main::lxdebug->enter_sub();
3538 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3540 $main::lxdebug->leave_sub();
3543 sub prepare_for_printing {
3546 $self->{templates} ||= $::myconfig{templates};
3547 $self->{formname} ||= $self->{type};
3548 $self->{media} ||= 'email';
3550 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3552 # set shipto from billto unless set
3553 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3554 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3555 $self->{shiptoname} = $::myconfig{company};
3556 $self->{shiptostreet} = $::myconfig{address};
3559 my $language = $self->{language} ? '_' . $self->{language} : '';
3561 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3562 if ($self->{language_id}) {
3563 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3565 $output_dateformat = $::myconfig{dateformat};
3566 $output_numberformat = $::myconfig{numberformat};
3567 $output_longdates = 1;
3570 # Retrieve accounts for tax calculation.
3571 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3573 if ($self->{type} =~ /_delivery_order$/) {
3574 DO->order_details();
3575 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3576 OE->order_details(\%::myconfig, $self);
3578 IS->invoice_details(\%::myconfig, $self, $::locale);
3581 # Chose extension & set source file name
3582 my $extension = 'html';
3583 if ($self->{format} eq 'postscript') {
3584 $self->{postscript} = 1;
3586 } elsif ($self->{"format"} =~ /pdf/) {
3588 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3589 } elsif ($self->{"format"} =~ /opendocument/) {
3590 $self->{opendocument} = 1;
3592 } elsif ($self->{"format"} =~ /excel/) {
3597 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3598 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3599 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3602 $self->format_dates($output_dateformat, $output_longdates,
3603 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3604 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3605 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3607 $self->reformat_numbers($output_numberformat, 2,
3608 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3609 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3611 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3613 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3615 if (scalar @{ $cvar_date_fields }) {
3616 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3619 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3620 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3627 my ($self, $dateformat, $longformat, @indices) = @_;
3629 $dateformat ||= $::myconfig{dateformat};
3631 foreach my $idx (@indices) {
3632 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3633 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3634 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3638 next unless defined $self->{$idx};
3640 if (!ref($self->{$idx})) {
3641 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3643 } elsif (ref($self->{$idx}) eq "ARRAY") {
3644 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3645 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3651 sub reformat_numbers {
3652 my ($self, $numberformat, $places, @indices) = @_;
3654 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3656 foreach my $idx (@indices) {
3657 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3658 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3659 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3663 next unless defined $self->{$idx};
3665 if (!ref($self->{$idx})) {
3666 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3668 } elsif (ref($self->{$idx}) eq "ARRAY") {
3669 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3670 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3675 my $saved_numberformat = $::myconfig{numberformat};
3676 $::myconfig{numberformat} = $numberformat;
3678 foreach my $idx (@indices) {
3679 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3680 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3681 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3685 next unless defined $self->{$idx};
3687 if (!ref($self->{$idx})) {
3688 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3690 } elsif (ref($self->{$idx}) eq "ARRAY") {
3691 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3692 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3697 $::myconfig{numberformat} = $saved_numberformat;
3706 SL::Form.pm - main data object.
3710 This is the main data object of Lx-Office.
3711 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3712 Points of interest for a beginner are:
3714 - $form->error - renders a generic error in html. accepts an error message
3715 - $form->get_standard_dbh - returns a database connection for the
3717 =head1 SPECIAL FUNCTIONS
3719 =head2 C<_store_value()>
3721 parses a complex var name, and stores it in the form.
3724 $form->_store_value($key, $value);
3726 keys must start with a string, and can contain various tokens.
3727 supported key structures are:
3730 simple key strings work as expected
3735 separating two keys by a dot (.) will result in a hash lookup for the inner value
3736 this is similar to the behaviour of java and templating mechanisms.
3738 filter.description => $form->{filter}->{description}
3740 3. array+hashref access
3742 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3743 using [+] instead of [] will force a new array index. this is useful for recurring
3744 data structures like part lists. put a [+] into the first varname, and use [] on the
3747 repeating these names in your template:
3750 invoice.items[].parts_id
3754 $form->{invoice}->{items}->[
3768 using brackets at the end of a name will result in a pure array to be created.
3769 note that you mustn't use [+], which is reserved for array+hash access and will
3770 result in undefined behaviour in array context.
3772 filter.status[] => $form->{status}->[ val1, val2, ... ]
3774 =head2 C<update_business> PARAMS
3777 \%config, - config hashref
3778 $business_id, - business id
3779 $dbh - optional database handle
3781 handles business (thats customer/vendor types) sequences.
3783 special behaviour for empty strings in customerinitnumber field:
3784 will in this case not increase the value, and return undef.
3786 =head2 C<redirect_header> $url
3788 Generates a HTTP redirection header for the new C<$url>. Constructs an
3789 absolute URL including scheme, host name and port. If C<$url> is a
3790 relative URL then it is considered relative to Lx-Office base URL.
3792 This function C<die>s if headers have already been created with
3793 C<$::form-E<gt>header>.
3797 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3798 print $::form->redirect_header('http://www.lx-office.org/');
3802 Generates a general purpose http/html header and includes most of the scripts
3803 ans stylesheets needed.
3805 Only one header will be generated. If the method was already called in this
3806 request it will not output anything and return undef. Also if no
3807 HTTP_USER_AGENT is found, no header is generated.
3809 Although header does not accept parameters itself, it will honor special
3810 hashkeys of its Form instance:
3818 If one of these is set, a http-equiv refresh is generated. Missing parameters
3819 default to 3 seconds and the refering url.
3825 If these are arrayrefs the contents will be inlined into the header.
3829 If true, a css snippet will be generated that sets the page in landscape mode.
3833 Used to override the default favicon.
3837 A html page title will be generated from this