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 $file = "templates/webpages/${file}.html";
785 my $info = "Web page template '${file}' not found.\n";
786 print qq|<pre>$info</pre>|;
790 if ($self->{"DEBUG"}) {
791 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
794 if ($additional_params->{"DEBUG"}) {
795 $additional_params->{"DEBUG"} =
796 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
799 if (%main::myconfig) {
800 $::myconfig{jsc_dateformat} = apply {
804 } $::myconfig{"dateformat"};
805 $additional_params->{"myconfig"} ||= \%::myconfig;
806 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
809 $additional_params->{"conf_dbcharset"} = $::lx_office_conf{system}->{dbcharset};
810 $additional_params->{"conf_webdav"} = $::lx_office_conf{features}->{webdav};
811 $additional_params->{"conf_lizenzen"} = $::lx_office_conf{features}->{lizenzen};
812 $additional_params->{"conf_latex_templates"} = $::lx_office_conf{print_templates}->{latex};
813 $additional_params->{"conf_opendocument_templates"} = $::lx_office_conf{print_templates}->{opendocument};
814 $additional_params->{"conf_vertreter"} = $::lx_office_conf{features}->{vertreter};
815 $additional_params->{"conf_show_best_before"} = $::lx_office_conf{features}->{show_best_before};
816 $additional_params->{"conf_parts_image_css"} = $::lx_office_conf{features}->{parts_image_css};
817 $additional_params->{"conf_parts_listing_images"} = $::lx_office_conf{features}->{parts_listing_images};
818 $additional_params->{"conf_parts_show_image"} = $::lx_office_conf{features}->{parts_show_image};
820 if (%main::debug_options) {
821 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
824 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
825 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
826 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
830 $main::lxdebug->leave_sub();
835 sub parse_html_template {
836 $main::lxdebug->enter_sub();
838 my ($self, $file, $additional_params) = @_;
840 $additional_params ||= { };
842 my $real_file = $self->_prepare_html_template($file, $additional_params);
843 my $template = $self->template || $self->init_template;
845 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
848 $template->process($real_file, $additional_params, \$output) || die $template->error;
850 $main::lxdebug->leave_sub();
858 return if $self->template;
860 return $self->template(Template->new({
865 'PLUGIN_BASE' => 'SL::Template::Plugin',
866 'INCLUDE_PATH' => '.:templates/webpages',
867 'COMPILE_EXT' => '.tcc',
868 'COMPILE_DIR' => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
874 $self->{template_object} = shift if @_;
875 return $self->{template_object};
878 sub show_generic_error {
879 $main::lxdebug->enter_sub();
881 my ($self, $error, %params) = @_;
883 if ($self->{__ERROR_HANDLER}) {
884 $self->{__ERROR_HANDLER}->($error);
885 $main::lxdebug->leave_sub();
890 'title_error' => $params{title},
891 'label_error' => $error,
894 if ($params{action}) {
897 map { delete($self->{$_}); } qw(action);
898 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
900 $add_params->{SHOW_BUTTON} = 1;
901 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
902 $add_params->{VARIABLES} = \@vars;
904 } elsif ($params{back_button}) {
905 $add_params->{SHOW_BACK_BUTTON} = 1;
908 $self->{title} = $params{title} if $params{title};
911 print $self->parse_html_template("generic/error", $add_params);
913 print STDERR "Error: $error\n";
915 $main::lxdebug->leave_sub();
920 sub show_generic_information {
921 $main::lxdebug->enter_sub();
923 my ($self, $text, $title) = @_;
926 'title_information' => $title,
927 'label_information' => $text,
930 $self->{title} = $title if ($title);
933 print $self->parse_html_template("generic/information", $add_params);
935 $main::lxdebug->leave_sub();
940 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
941 # changed it to accept an arbitrary number of triggers - sschoeling
943 $main::lxdebug->enter_sub();
946 my $myconfig = shift;
949 # set dateform for jsscript
952 "dd.mm.yy" => "%d.%m.%Y",
953 "dd-mm-yy" => "%d-%m-%Y",
954 "dd/mm/yy" => "%d/%m/%Y",
955 "mm/dd/yy" => "%m/%d/%Y",
956 "mm-dd-yy" => "%m-%d-%Y",
957 "yyyy-mm-dd" => "%Y-%m-%d",
960 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
961 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
968 inputField : "| . (shift) . qq|",
969 ifFormat :"$ifFormat",
970 align : "| . (shift) . qq|",
971 button : "| . (shift) . qq|"
977 <script type="text/javascript">
978 <!--| . join("", @triggers) . qq|//-->
982 $main::lxdebug->leave_sub();
985 } #end sub write_trigger
988 $main::lxdebug->enter_sub();
990 my ($self, $msg) = @_;
992 if (!$self->{callback}) {
996 print $::form->redirect_header($self->{callback});
1001 $main::lxdebug->leave_sub();
1004 # sort of columns removed - empty sub
1006 $main::lxdebug->enter_sub();
1008 my ($self, @columns) = @_;
1010 $main::lxdebug->leave_sub();
1016 $main::lxdebug->enter_sub(2);
1018 my ($self, $myconfig, $amount, $places, $dash) = @_;
1020 if ($amount eq "") {
1024 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1026 my $neg = ($amount =~ s/^-//);
1027 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1029 if (defined($places) && ($places ne '')) {
1035 my ($actual_places) = ($amount =~ /\.(\d+)/);
1036 $actual_places = length($actual_places);
1037 $places = $actual_places > $places ? $actual_places : $places;
1040 $amount = $self->round_amount($amount, $places);
1043 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1044 my @p = split(/\./, $amount); # split amount at decimal point
1046 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1049 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1052 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1053 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1054 ($neg ? "-$amount" : "$amount" ) ;
1058 $main::lxdebug->leave_sub(2);
1062 sub format_amount_units {
1063 $main::lxdebug->enter_sub();
1068 my $myconfig = \%main::myconfig;
1069 my $amount = $params{amount} * 1;
1070 my $places = $params{places};
1071 my $part_unit_name = $params{part_unit};
1072 my $amount_unit_name = $params{amount_unit};
1073 my $conv_units = $params{conv_units};
1074 my $max_places = $params{max_places};
1076 if (!$part_unit_name) {
1077 $main::lxdebug->leave_sub();
1081 AM->retrieve_all_units();
1082 my $all_units = $main::all_units;
1084 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1085 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1088 if (!scalar @{ $conv_units }) {
1089 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1090 $main::lxdebug->leave_sub();
1094 my $part_unit = $all_units->{$part_unit_name};
1095 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1097 $amount *= $conv_unit->{factor};
1102 foreach my $unit (@$conv_units) {
1103 my $last = $unit->{name} eq $part_unit->{name};
1105 $num = int($amount / $unit->{factor});
1106 $amount -= $num * $unit->{factor};
1109 if ($last ? $amount : $num) {
1110 push @values, { "unit" => $unit->{name},
1111 "amount" => $last ? $amount / $unit->{factor} : $num,
1112 "places" => $last ? $places : 0 };
1119 push @values, { "unit" => $part_unit_name,
1124 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1126 $main::lxdebug->leave_sub();
1132 $main::lxdebug->enter_sub(2);
1137 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1138 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1139 $input =~ s/\#\#/\#/g;
1141 $main::lxdebug->leave_sub(2);
1149 $main::lxdebug->enter_sub(2);
1151 my ($self, $myconfig, $amount) = @_;
1153 if ( ($myconfig->{numberformat} eq '1.000,00')
1154 || ($myconfig->{numberformat} eq '1000,00')) {
1159 if ($myconfig->{numberformat} eq "1'000.00") {
1165 $main::lxdebug->leave_sub(2);
1167 return ($amount * 1);
1171 $main::lxdebug->enter_sub(2);
1173 my ($self, $amount, $places) = @_;
1176 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1178 # Round amounts to eight places before rounding to the requested
1179 # number of places. This gets rid of errors due to internal floating
1180 # point representation.
1181 $amount = $self->round_amount($amount, 8) if $places < 8;
1182 $amount = $amount * (10**($places));
1183 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1185 $main::lxdebug->leave_sub(2);
1187 return $round_amount;
1191 sub parse_template {
1192 $main::lxdebug->enter_sub();
1194 my ($self, $myconfig) = @_;
1199 my $userspath = $::lx_office_conf{paths}->{userspath};
1201 $self->{"cwd"} = getcwd();
1202 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1207 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1208 $template_type = 'OpenDocument';
1209 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1211 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1212 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1213 $template_type = 'LaTeX';
1214 $ext_for_format = 'pdf';
1216 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1217 $template_type = 'HTML';
1218 $ext_for_format = 'html';
1220 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1221 $template_type = 'XML';
1222 $ext_for_format = 'xml';
1224 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1225 $template_type = 'XML';
1227 } elsif ( $self->{"format"} =~ /excel/i ) {
1228 $template_type = 'Excel';
1229 $ext_for_format = 'xls';
1231 } elsif ( defined $self->{'format'}) {
1232 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1234 } elsif ( $self->{'format'} eq '' ) {
1235 $self->error("No Outputformat given: $self->{'format'}");
1237 } else { #Catch the rest
1238 $self->error("Outputformat not defined: $self->{'format'}");
1241 my $template = SL::Template::create(type => $template_type,
1242 file_name => $self->{IN},
1244 myconfig => $myconfig,
1245 userspath => $userspath);
1247 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1248 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1250 if (!$self->{employee_id}) {
1251 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1254 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1255 map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1257 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1259 # OUT is used for the media, screen, printer, email
1260 # for postscript we store a copy in a temporary file
1262 my $prepend_userspath;
1264 if (!$self->{tmpfile}) {
1265 $self->{tmpfile} = "${fileid}.$self->{IN}";
1266 $prepend_userspath = 1;
1269 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1271 $self->{tmpfile} =~ s|.*/||;
1272 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1273 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1275 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1276 $out = $self->{OUT};
1277 $self->{OUT} = ">$self->{tmpfile}";
1283 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1284 $result = $template->parse(*OUT);
1289 $result = $template->parse(*STDOUT);
1294 $self->error("$self->{IN} : " . $template->get_error());
1297 if ($self->{media} eq 'file') {
1298 copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1300 chdir("$self->{cwd}");
1302 $::lxdebug->leave_sub();
1307 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1309 if ($self->{media} eq 'email') {
1311 my $mail = new Mailer;
1313 map { $mail->{$_} = $self->{$_} }
1314 qw(cc bcc subject message version format);
1315 $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1316 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1317 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1318 $mail->{fileid} = "$fileid.";
1319 $myconfig->{signature} =~ s/\r//g;
1321 # if we send html or plain text inline
1322 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1323 $mail->{contenttype} = "text/html";
1325 $mail->{message} =~ s/\r//g;
1326 $mail->{message} =~ s/\n/<br>\n/g;
1327 $myconfig->{signature} =~ s/\n/<br>\n/g;
1328 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1330 open(IN, $self->{tmpfile})
1331 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1333 $mail->{message} .= $_;
1340 if (!$self->{"do_not_attach"}) {
1341 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1342 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1343 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1344 "name" => $attachment_name }];
1347 $mail->{message} =~ s/\r//g;
1348 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1352 my $err = $mail->send();
1353 $self->error($self->cleanup . "$err") if ($err);
1357 $self->{OUT} = $out;
1359 my $numbytes = (-s $self->{tmpfile});
1360 open(IN, $self->{tmpfile})
1361 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1364 $self->{copies} = 1 unless $self->{media} eq 'printer';
1366 chdir("$self->{cwd}");
1367 #print(STDERR "Kopien $self->{copies}\n");
1368 #print(STDERR "OUT $self->{OUT}\n");
1369 for my $i (1 .. $self->{copies}) {
1371 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1372 print OUT while <IN>;
1377 $self->{attachment_filename} = ($self->{attachment_filename})
1378 ? $self->{attachment_filename}
1379 : $self->generate_attachment_filename();
1381 # launch application
1382 print qq|Content-Type: | . $template->get_mime_type() . qq|
1383 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1384 Content-Length: $numbytes
1388 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1399 chdir("$self->{cwd}");
1400 $main::lxdebug->leave_sub();
1403 sub get_formname_translation {
1404 $main::lxdebug->enter_sub();
1405 my ($self, $formname) = @_;
1407 $formname ||= $self->{formname};
1409 my %formname_translations = (
1410 bin_list => $main::locale->text('Bin List'),
1411 credit_note => $main::locale->text('Credit Note'),
1412 invoice => $main::locale->text('Invoice'),
1413 pick_list => $main::locale->text('Pick List'),
1414 proforma => $main::locale->text('Proforma Invoice'),
1415 purchase_order => $main::locale->text('Purchase Order'),
1416 request_quotation => $main::locale->text('RFQ'),
1417 sales_order => $main::locale->text('Confirmation'),
1418 sales_quotation => $main::locale->text('Quotation'),
1419 storno_invoice => $main::locale->text('Storno Invoice'),
1420 sales_delivery_order => $main::locale->text('Delivery Order'),
1421 purchase_delivery_order => $main::locale->text('Delivery Order'),
1422 dunning => $main::locale->text('Dunning'),
1425 $main::lxdebug->leave_sub();
1426 return $formname_translations{$formname}
1429 sub get_number_prefix_for_type {
1430 $main::lxdebug->enter_sub();
1434 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1435 : ($self->{type} =~ /_quotation$/) ? 'quo'
1436 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1439 $main::lxdebug->leave_sub();
1443 sub get_extension_for_format {
1444 $main::lxdebug->enter_sub();
1447 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1448 : $self->{format} =~ /postscript/i ? ".ps"
1449 : $self->{format} =~ /opendocument/i ? ".odt"
1450 : $self->{format} =~ /excel/i ? ".xls"
1451 : $self->{format} =~ /html/i ? ".html"
1454 $main::lxdebug->leave_sub();
1458 sub generate_attachment_filename {
1459 $main::lxdebug->enter_sub();
1462 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1463 my $prefix = $self->get_number_prefix_for_type();
1465 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1466 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1468 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1469 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1472 $attachment_filename = "";
1475 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1476 $attachment_filename =~ s|[\s/\\]+|_|g;
1478 $main::lxdebug->leave_sub();
1479 return $attachment_filename;
1482 sub generate_email_subject {
1483 $main::lxdebug->enter_sub();
1486 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1487 my $prefix = $self->get_number_prefix_for_type();
1489 if ($subject && $self->{"${prefix}number"}) {
1490 $subject .= " " . $self->{"${prefix}number"}
1493 $main::lxdebug->leave_sub();
1498 $main::lxdebug->enter_sub();
1502 chdir("$self->{tmpdir}");
1505 if (-f "$self->{tmpfile}.err") {
1506 open(FH, "$self->{tmpfile}.err");
1511 if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1512 $self->{tmpfile} =~ s|.*/||g;
1514 $self->{tmpfile} =~ s/\.\w+$//g;
1515 my $tmpfile = $self->{tmpfile};
1516 unlink(<$tmpfile.*>);
1519 chdir("$self->{cwd}");
1521 $main::lxdebug->leave_sub();
1527 $main::lxdebug->enter_sub();
1529 my ($self, $date, $myconfig) = @_;
1532 if ($date && $date =~ /\D/) {
1534 if ($myconfig->{dateformat} =~ /^yy/) {
1535 ($yy, $mm, $dd) = split /\D/, $date;
1537 if ($myconfig->{dateformat} =~ /^mm/) {
1538 ($mm, $dd, $yy) = split /\D/, $date;
1540 if ($myconfig->{dateformat} =~ /^dd/) {
1541 ($dd, $mm, $yy) = split /\D/, $date;
1546 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1547 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1549 $dd = "0$dd" if ($dd < 10);
1550 $mm = "0$mm" if ($mm < 10);
1552 $date = "$yy$mm$dd";
1555 $main::lxdebug->leave_sub();
1560 # Database routines used throughout
1562 sub _dbconnect_options {
1564 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1571 $main::lxdebug->enter_sub(2);
1573 my ($self, $myconfig) = @_;
1575 # connect to database
1576 my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1580 if ($myconfig->{dboptions}) {
1581 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1584 $main::lxdebug->leave_sub(2);
1589 sub dbconnect_noauto {
1590 $main::lxdebug->enter_sub();
1592 my ($self, $myconfig) = @_;
1594 # connect to database
1595 my $dbh = SL::DBConnect->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1599 if ($myconfig->{dboptions}) {
1600 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1603 $main::lxdebug->leave_sub();
1608 sub get_standard_dbh {
1609 $main::lxdebug->enter_sub(2);
1612 my $myconfig = shift || \%::myconfig;
1614 if ($standard_dbh && !$standard_dbh->{Active}) {
1615 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1616 undef $standard_dbh;
1619 $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1621 $main::lxdebug->leave_sub(2);
1623 return $standard_dbh;
1627 $main::lxdebug->enter_sub();
1629 my ($self, $date, $myconfig) = @_;
1630 my $dbh = $self->dbconnect($myconfig);
1632 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1633 my $sth = prepare_execute_query($self, $dbh, $query, conv_date($date));
1635 # Falls $date = '' - Fehlermeldung aus der Datenbank. Ich denke,
1636 # es ist sicher ein conv_date vorher IMMER auszuführen.
1637 # Testfälle ohne definiertes closedto:
1638 # Leere Datumseingabe i.O.
1639 # SELECT 1 FROM defaults WHERE '' < closedto
1640 # normale Zahlungsbuchung über Rechnungsmaske i.O.
1641 # SELECT 1 FROM defaults WHERE '10.05.2011' < closedto
1642 # Testfälle mit definiertem closedto (30.04.2011):
1643 # Leere Datumseingabe i.O.
1644 # SELECT 1 FROM defaults WHERE '' < closedto
1645 # normale Buchung im geschloßenem Zeitraum i.O.
1646 # SELECT 1 FROM defaults WHERE '21.04.2011' < closedto
1647 # Fehlermeldung: Es können keine Zahlungen für abgeschlossene Bücher gebucht werden!
1648 # normale Buchung in aktiver Buchungsperiode i.O.
1649 # SELECT 1 FROM defaults WHERE '01.05.2011' < closedto
1651 my ($closed) = $sth->fetchrow_array;
1653 $main::lxdebug->leave_sub();
1658 sub update_balance {
1659 $main::lxdebug->enter_sub();
1661 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1663 # if we have a value, go do it
1666 # retrieve balance from table
1667 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1668 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1669 my ($balance) = $sth->fetchrow_array;
1675 $query = "UPDATE $table SET $field = $balance WHERE $where";
1676 do_query($self, $dbh, $query, @values);
1678 $main::lxdebug->leave_sub();
1681 sub update_exchangerate {
1682 $main::lxdebug->enter_sub();
1684 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1686 # some sanity check for currency
1688 $main::lxdebug->leave_sub();
1691 $query = qq|SELECT curr FROM defaults|;
1693 my ($currency) = selectrow_query($self, $dbh, $query);
1694 my ($defaultcurrency) = split m/:/, $currency;
1697 if ($curr eq $defaultcurrency) {
1698 $main::lxdebug->leave_sub();
1702 $query = qq|SELECT e.curr FROM exchangerate e
1703 WHERE e.curr = ? AND e.transdate = ?
1705 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1714 $buy = conv_i($buy, "NULL");
1715 $sell = conv_i($sell, "NULL");
1718 if ($buy != 0 && $sell != 0) {
1719 $set = "buy = $buy, sell = $sell";
1720 } elsif ($buy != 0) {
1721 $set = "buy = $buy";
1722 } elsif ($sell != 0) {
1723 $set = "sell = $sell";
1726 if ($sth->fetchrow_array) {
1727 $query = qq|UPDATE exchangerate
1733 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1734 VALUES (?, $buy, $sell, ?)|;
1737 do_query($self, $dbh, $query, $curr, $transdate);
1739 $main::lxdebug->leave_sub();
1742 sub save_exchangerate {
1743 $main::lxdebug->enter_sub();
1745 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1747 my $dbh = $self->dbconnect($myconfig);
1751 $buy = $rate if $fld eq 'buy';
1752 $sell = $rate if $fld eq 'sell';
1755 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1760 $main::lxdebug->leave_sub();
1763 sub get_exchangerate {
1764 $main::lxdebug->enter_sub();
1766 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1769 unless ($transdate) {
1770 $main::lxdebug->leave_sub();
1774 $query = qq|SELECT curr FROM defaults|;
1776 my ($currency) = selectrow_query($self, $dbh, $query);
1777 my ($defaultcurrency) = split m/:/, $currency;
1779 if ($currency eq $defaultcurrency) {
1780 $main::lxdebug->leave_sub();
1784 $query = qq|SELECT e.$fld FROM exchangerate e
1785 WHERE e.curr = ? AND e.transdate = ?|;
1786 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1790 $main::lxdebug->leave_sub();
1792 return $exchangerate;
1795 sub check_exchangerate {
1796 $main::lxdebug->enter_sub();
1798 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1800 if ($fld !~/^buy|sell$/) {
1801 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1804 unless ($transdate) {
1805 $main::lxdebug->leave_sub();
1809 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1811 if ($currency eq $defaultcurrency) {
1812 $main::lxdebug->leave_sub();
1816 my $dbh = $self->get_standard_dbh($myconfig);
1817 my $query = qq|SELECT e.$fld FROM exchangerate e
1818 WHERE e.curr = ? AND e.transdate = ?|;
1820 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1822 $main::lxdebug->leave_sub();
1824 return $exchangerate;
1827 sub get_all_currencies {
1828 $main::lxdebug->enter_sub();
1831 my $myconfig = shift || \%::myconfig;
1832 my $dbh = $self->get_standard_dbh($myconfig);
1834 my $query = qq|SELECT curr FROM defaults|;
1836 my ($curr) = selectrow_query($self, $dbh, $query);
1837 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1839 $main::lxdebug->leave_sub();
1844 sub get_default_currency {
1845 $main::lxdebug->enter_sub();
1847 my ($self, $myconfig) = @_;
1848 my @currencies = $self->get_all_currencies($myconfig);
1850 $main::lxdebug->leave_sub();
1852 return $currencies[0];
1855 sub set_payment_options {
1856 $main::lxdebug->enter_sub();
1858 my ($self, $myconfig, $transdate) = @_;
1860 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1862 my $dbh = $self->get_standard_dbh($myconfig);
1865 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1866 qq|FROM payment_terms p | .
1869 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1870 $self->{payment_terms}) =
1871 selectrow_query($self, $dbh, $query, $self->{payment_id});
1873 if ($transdate eq "") {
1874 if ($self->{invdate}) {
1875 $transdate = $self->{invdate};
1877 $transdate = $self->{transdate};
1882 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1883 qq|FROM payment_terms|;
1884 ($self->{netto_date}, $self->{skonto_date}) =
1885 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1887 my ($invtotal, $total);
1888 my (%amounts, %formatted_amounts);
1890 if ($self->{type} =~ /_order$/) {
1891 $amounts{invtotal} = $self->{ordtotal};
1892 $amounts{total} = $self->{ordtotal};
1894 } elsif ($self->{type} =~ /_quotation$/) {
1895 $amounts{invtotal} = $self->{quototal};
1896 $amounts{total} = $self->{quototal};
1899 $amounts{invtotal} = $self->{invtotal};
1900 $amounts{total} = $self->{total};
1902 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1904 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1906 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1907 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1908 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1910 foreach (keys %amounts) {
1911 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1912 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1915 if ($self->{"language_id"}) {
1917 qq|SELECT t.translation, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1918 qq|FROM generic_translations t | .
1919 qq|LEFT JOIN language l ON t.language_id = l.id | .
1920 qq|WHERE (t.language_id = ?)
1921 AND (t.translation_id = ?)
1922 AND (t.translation_type = 'SL::DB::PaymentTerm/description_long')|;
1923 my ($description_long, $output_numberformat, $output_dateformat,
1924 $output_longdates) =
1925 selectrow_query($self, $dbh, $query,
1926 $self->{"language_id"}, $self->{"payment_id"});
1928 $self->{payment_terms} = $description_long if ($description_long);
1930 if ($output_dateformat) {
1931 foreach my $key (qw(netto_date skonto_date)) {
1933 $main::locale->reformat_date($myconfig, $self->{$key},
1939 if ($output_numberformat &&
1940 ($output_numberformat ne $myconfig->{"numberformat"})) {
1941 my $saved_numberformat = $myconfig->{"numberformat"};
1942 $myconfig->{"numberformat"} = $output_numberformat;
1943 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1944 $myconfig->{"numberformat"} = $saved_numberformat;
1948 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1949 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1950 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1951 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1952 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1953 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1954 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1956 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1958 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1960 $main::lxdebug->leave_sub();
1964 sub get_template_language {
1965 $main::lxdebug->enter_sub();
1967 my ($self, $myconfig) = @_;
1969 my $template_code = "";
1971 if ($self->{language_id}) {
1972 my $dbh = $self->get_standard_dbh($myconfig);
1973 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1974 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1977 $main::lxdebug->leave_sub();
1979 return $template_code;
1982 sub get_printer_code {
1983 $main::lxdebug->enter_sub();
1985 my ($self, $myconfig) = @_;
1987 my $template_code = "";
1989 if ($self->{printer_id}) {
1990 my $dbh = $self->get_standard_dbh($myconfig);
1991 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1992 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1995 $main::lxdebug->leave_sub();
1997 return $template_code;
2001 $main::lxdebug->enter_sub();
2003 my ($self, $myconfig) = @_;
2005 my $template_code = "";
2007 if ($self->{shipto_id}) {
2008 my $dbh = $self->get_standard_dbh($myconfig);
2009 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
2010 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
2011 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
2014 $main::lxdebug->leave_sub();
2018 $main::lxdebug->enter_sub();
2020 my ($self, $dbh, $id, $module) = @_;
2025 foreach my $item (qw(name department_1 department_2 street zipcode city country
2026 contact cp_gender phone fax email)) {
2027 if ($self->{"shipto$item"}) {
2028 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2030 push(@values, $self->{"shipto${item}"});
2034 if ($self->{shipto_id}) {
2035 my $query = qq|UPDATE shipto set
2037 shiptodepartment_1 = ?,
2038 shiptodepartment_2 = ?,
2044 shiptocp_gender = ?,
2048 WHERE shipto_id = ?|;
2049 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2051 my $query = qq|SELECT * FROM shipto
2052 WHERE shiptoname = ? AND
2053 shiptodepartment_1 = ? AND
2054 shiptodepartment_2 = ? AND
2055 shiptostreet = ? AND
2056 shiptozipcode = ? AND
2058 shiptocountry = ? AND
2059 shiptocontact = ? AND
2060 shiptocp_gender = ? AND
2066 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2069 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2070 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2071 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2072 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2073 do_query($self, $dbh, $query, $id, @values, $module);
2078 $main::lxdebug->leave_sub();
2082 $main::lxdebug->enter_sub();
2084 my ($self, $dbh) = @_;
2086 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2088 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2089 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2090 $self->{"employee_id"} *= 1;
2092 $main::lxdebug->leave_sub();
2095 sub get_employee_data {
2096 $main::lxdebug->enter_sub();
2101 Common::check_params(\%params, qw(prefix));
2102 Common::check_params_x(\%params, qw(id));
2105 $main::lxdebug->leave_sub();
2109 my $myconfig = \%main::myconfig;
2110 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2112 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2115 my $user = User->new($login);
2116 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2118 $self->{$params{prefix} . '_login'} = $login;
2119 $self->{$params{prefix} . '_name'} ||= $login;
2122 $main::lxdebug->leave_sub();
2126 $main::lxdebug->enter_sub();
2128 my ($self, $myconfig, $reference_date) = @_;
2130 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2132 my $dbh = $self->get_standard_dbh($myconfig);
2133 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2134 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2136 $main::lxdebug->leave_sub();
2142 $main::lxdebug->enter_sub();
2144 my ($self, $dbh, $id, $key) = @_;
2146 $key = "all_contacts" unless ($key);
2150 $main::lxdebug->leave_sub();
2155 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2156 qq|FROM contacts | .
2157 qq|WHERE cp_cv_id = ? | .
2158 qq|ORDER BY lower(cp_name)|;
2160 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2162 $main::lxdebug->leave_sub();
2166 $main::lxdebug->enter_sub();
2168 my ($self, $dbh, $key) = @_;
2170 my ($all, $old_id, $where, @values);
2172 if (ref($key) eq "HASH") {
2175 $key = "ALL_PROJECTS";
2177 foreach my $p (keys(%{$params})) {
2179 $all = $params->{$p};
2180 } elsif ($p eq "old_id") {
2181 $old_id = $params->{$p};
2182 } elsif ($p eq "key") {
2183 $key = $params->{$p};
2189 $where = "WHERE active ";
2191 if (ref($old_id) eq "ARRAY") {
2192 my @ids = grep({ $_ } @{$old_id});
2194 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2195 push(@values, @ids);
2198 $where .= " OR (id = ?) ";
2199 push(@values, $old_id);
2205 qq|SELECT id, projectnumber, description, active | .
2208 qq|ORDER BY lower(projectnumber)|;
2210 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2212 $main::lxdebug->leave_sub();
2216 $main::lxdebug->enter_sub();
2218 my ($self, $dbh, $vc_id, $key) = @_;
2220 $key = "all_shipto" unless ($key);
2223 # get shipping addresses
2224 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2226 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2232 $main::lxdebug->leave_sub();
2236 $main::lxdebug->enter_sub();
2238 my ($self, $dbh, $key) = @_;
2240 $key = "all_printers" unless ($key);
2242 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2244 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2246 $main::lxdebug->leave_sub();
2250 $main::lxdebug->enter_sub();
2252 my ($self, $dbh, $params) = @_;
2255 $key = $params->{key};
2256 $key = "all_charts" unless ($key);
2258 my $transdate = quote_db_date($params->{transdate});
2261 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2263 qq|LEFT JOIN taxkeys tk ON | .
2264 qq|(tk.id = (SELECT id FROM taxkeys | .
2265 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2266 qq| ORDER BY startdate DESC LIMIT 1)) | .
2267 qq|ORDER BY c.accno|;
2269 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2271 $main::lxdebug->leave_sub();
2274 sub _get_taxcharts {
2275 $main::lxdebug->enter_sub();
2277 my ($self, $dbh, $params) = @_;
2279 my $key = "all_taxcharts";
2282 if (ref $params eq 'HASH') {
2283 $key = $params->{key} if ($params->{key});
2284 if ($params->{module} eq 'AR') {
2285 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2287 } elsif ($params->{module} eq 'AP') {
2288 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2295 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2297 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2299 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2301 $main::lxdebug->leave_sub();
2305 $main::lxdebug->enter_sub();
2307 my ($self, $dbh, $key) = @_;
2309 $key = "all_taxzones" unless ($key);
2311 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2313 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2315 $main::lxdebug->leave_sub();
2318 sub _get_employees {
2319 $main::lxdebug->enter_sub();
2321 my ($self, $dbh, $default_key, $key) = @_;
2323 $key = $default_key unless ($key);
2324 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2326 $main::lxdebug->leave_sub();
2329 sub _get_business_types {
2330 $main::lxdebug->enter_sub();
2332 my ($self, $dbh, $key) = @_;
2334 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2335 $options->{key} ||= "all_business_types";
2338 if (exists $options->{salesman}) {
2339 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2342 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2344 $main::lxdebug->leave_sub();
2347 sub _get_languages {
2348 $main::lxdebug->enter_sub();
2350 my ($self, $dbh, $key) = @_;
2352 $key = "all_languages" unless ($key);
2354 my $query = qq|SELECT * FROM language ORDER BY id|;
2356 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2358 $main::lxdebug->leave_sub();
2361 sub _get_dunning_configs {
2362 $main::lxdebug->enter_sub();
2364 my ($self, $dbh, $key) = @_;
2366 $key = "all_dunning_configs" unless ($key);
2368 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2370 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2372 $main::lxdebug->leave_sub();
2375 sub _get_currencies {
2376 $main::lxdebug->enter_sub();
2378 my ($self, $dbh, $key) = @_;
2380 $key = "all_currencies" unless ($key);
2382 my $query = qq|SELECT curr AS currency FROM defaults|;
2384 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2386 $main::lxdebug->leave_sub();
2390 $main::lxdebug->enter_sub();
2392 my ($self, $dbh, $key) = @_;
2394 $key = "all_payments" unless ($key);
2396 my $query = qq|SELECT * FROM payment_terms ORDER BY sortkey|;
2398 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2400 $main::lxdebug->leave_sub();
2403 sub _get_customers {
2404 $main::lxdebug->enter_sub();
2406 my ($self, $dbh, $key) = @_;
2408 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2409 $options->{key} ||= "all_customers";
2410 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2413 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2414 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2415 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2417 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2418 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2420 $main::lxdebug->leave_sub();
2424 $main::lxdebug->enter_sub();
2426 my ($self, $dbh, $key) = @_;
2428 $key = "all_vendors" unless ($key);
2430 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2432 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2434 $main::lxdebug->leave_sub();
2437 sub _get_departments {
2438 $main::lxdebug->enter_sub();
2440 my ($self, $dbh, $key) = @_;
2442 $key = "all_departments" unless ($key);
2444 my $query = qq|SELECT * FROM department ORDER BY description|;
2446 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2448 $main::lxdebug->leave_sub();
2451 sub _get_warehouses {
2452 $main::lxdebug->enter_sub();
2454 my ($self, $dbh, $param) = @_;
2456 my ($key, $bins_key);
2458 if ('' eq ref $param) {
2462 $key = $param->{key};
2463 $bins_key = $param->{bins};
2466 my $query = qq|SELECT w.* FROM warehouse w
2467 WHERE (NOT w.invalid) AND
2468 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2469 ORDER BY w.sortkey|;
2471 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2474 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?
2475 ORDER BY description|;
2476 my $sth = prepare_query($self, $dbh, $query);
2478 foreach my $warehouse (@{ $self->{$key} }) {
2479 do_statement($self, $sth, $query, $warehouse->{id});
2480 $warehouse->{$bins_key} = [];
2482 while (my $ref = $sth->fetchrow_hashref()) {
2483 push @{ $warehouse->{$bins_key} }, $ref;
2489 $main::lxdebug->leave_sub();
2493 $main::lxdebug->enter_sub();
2495 my ($self, $dbh, $table, $key, $sortkey) = @_;
2497 my $query = qq|SELECT * FROM $table|;
2498 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2500 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2502 $main::lxdebug->leave_sub();
2506 # $main::lxdebug->enter_sub();
2508 # my ($self, $dbh, $key) = @_;
2510 # $key ||= "all_groups";
2512 # my $groups = $main::auth->read_groups();
2514 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2516 # $main::lxdebug->leave_sub();
2520 $main::lxdebug->enter_sub();
2525 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2526 my ($sth, $query, $ref);
2528 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2529 my $vc_id = $self->{"${vc}_id"};
2531 if ($params{"contacts"}) {
2532 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2535 if ($params{"shipto"}) {
2536 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2539 if ($params{"projects"} || $params{"all_projects"}) {
2540 $self->_get_projects($dbh, $params{"all_projects"} ?
2541 $params{"all_projects"} : $params{"projects"},
2542 $params{"all_projects"} ? 1 : 0);
2545 if ($params{"printers"}) {
2546 $self->_get_printers($dbh, $params{"printers"});
2549 if ($params{"languages"}) {
2550 $self->_get_languages($dbh, $params{"languages"});
2553 if ($params{"charts"}) {
2554 $self->_get_charts($dbh, $params{"charts"});
2557 if ($params{"taxcharts"}) {
2558 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2561 if ($params{"taxzones"}) {
2562 $self->_get_taxzones($dbh, $params{"taxzones"});
2565 if ($params{"employees"}) {
2566 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2569 if ($params{"salesmen"}) {
2570 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2573 if ($params{"business_types"}) {
2574 $self->_get_business_types($dbh, $params{"business_types"});
2577 if ($params{"dunning_configs"}) {
2578 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2581 if($params{"currencies"}) {
2582 $self->_get_currencies($dbh, $params{"currencies"});
2585 if($params{"customers"}) {
2586 $self->_get_customers($dbh, $params{"customers"});
2589 if($params{"vendors"}) {
2590 if (ref $params{"vendors"} eq 'HASH') {
2591 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2593 $self->_get_vendors($dbh, $params{"vendors"});
2597 if($params{"payments"}) {
2598 $self->_get_payments($dbh, $params{"payments"});
2601 if($params{"departments"}) {
2602 $self->_get_departments($dbh, $params{"departments"});
2605 if ($params{price_factors}) {
2606 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2609 if ($params{warehouses}) {
2610 $self->_get_warehouses($dbh, $params{warehouses});
2613 # if ($params{groups}) {
2614 # $self->_get_groups($dbh, $params{groups});
2617 if ($params{partsgroup}) {
2618 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2621 $main::lxdebug->leave_sub();
2624 # this sub gets the id and name from $table
2626 $main::lxdebug->enter_sub();
2628 my ($self, $myconfig, $table) = @_;
2630 # connect to database
2631 my $dbh = $self->get_standard_dbh($myconfig);
2633 $table = $table eq "customer" ? "customer" : "vendor";
2634 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2636 my ($query, @values);
2638 if (!$self->{openinvoices}) {
2640 if ($self->{customernumber} ne "") {
2641 $where = qq|(vc.customernumber ILIKE ?)|;
2642 push(@values, '%' . $self->{customernumber} . '%');
2644 $where = qq|(vc.name ILIKE ?)|;
2645 push(@values, '%' . $self->{$table} . '%');
2649 qq~SELECT vc.id, vc.name,
2650 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2652 WHERE $where AND (NOT vc.obsolete)
2656 qq~SELECT DISTINCT vc.id, vc.name,
2657 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2659 JOIN $table vc ON (a.${table}_id = vc.id)
2660 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2662 push(@values, '%' . $self->{$table} . '%');
2665 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2667 $main::lxdebug->leave_sub();
2669 return scalar(@{ $self->{name_list} });
2672 # the selection sub is used in the AR, AP, IS, IR and OE module
2675 $main::lxdebug->enter_sub();
2677 my ($self, $myconfig, $table, $module) = @_;
2680 my $dbh = $self->get_standard_dbh;
2682 $table = $table eq "customer" ? "customer" : "vendor";
2684 my $query = qq|SELECT count(*) FROM $table|;
2685 my ($count) = selectrow_query($self, $dbh, $query);
2687 # build selection list
2688 if ($count <= $myconfig->{vclimit}) {
2689 $query = qq|SELECT id, name, salesman_id
2690 FROM $table WHERE NOT obsolete
2692 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2696 $self->get_employee($dbh);
2698 # setup sales contacts
2699 $query = qq|SELECT e.id, e.name
2701 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2702 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2705 push(@{ $self->{all_employees} },
2706 { id => $self->{employee_id},
2707 name => $self->{employee} });
2709 # sort the whole thing
2710 @{ $self->{all_employees} } =
2711 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2713 if ($module eq 'AR') {
2715 # prepare query for departments
2716 $query = qq|SELECT id, description
2719 ORDER BY description|;
2722 $query = qq|SELECT id, description
2724 ORDER BY description|;
2727 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2730 $query = qq|SELECT id, description
2734 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2737 $query = qq|SELECT printer_description, id
2739 ORDER BY printer_description|;
2741 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2744 $query = qq|SELECT id, description
2748 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2750 $main::lxdebug->leave_sub();
2753 sub language_payment {
2754 $main::lxdebug->enter_sub();
2756 my ($self, $myconfig) = @_;
2758 my $dbh = $self->get_standard_dbh($myconfig);
2760 my $query = qq|SELECT id, description
2764 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2767 $query = qq|SELECT printer_description, id
2769 ORDER BY printer_description|;
2771 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2774 $query = qq|SELECT id, description
2778 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2780 # get buchungsgruppen
2781 $query = qq|SELECT id, description
2782 FROM buchungsgruppen|;
2784 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2786 $main::lxdebug->leave_sub();
2789 # this is only used for reports
2790 sub all_departments {
2791 $main::lxdebug->enter_sub();
2793 my ($self, $myconfig, $table) = @_;
2795 my $dbh = $self->get_standard_dbh($myconfig);
2798 if ($table eq 'customer') {
2799 $where = "WHERE role = 'P' ";
2802 my $query = qq|SELECT id, description
2805 ORDER BY description|;
2806 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2808 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2810 $main::lxdebug->leave_sub();
2814 $main::lxdebug->enter_sub();
2816 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2819 if ($table eq "customer") {
2828 $self->all_vc($myconfig, $table, $module);
2830 # get last customers or vendors
2831 my ($query, $sth, $ref);
2833 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2838 my $transdate = "current_date";
2839 if ($self->{transdate}) {
2840 $transdate = $dbh->quote($self->{transdate});
2843 # now get the account numbers
2844 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2845 FROM chart c, taxkeys tk
2846 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2847 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2850 $sth = $dbh->prepare($query);
2852 do_statement($self, $sth, $query, '%' . $module . '%');
2854 $self->{accounts} = "";
2855 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2857 foreach my $key (split(/:/, $ref->{link})) {
2858 if ($key =~ /\Q$module\E/) {
2860 # cross reference for keys
2861 $xkeyref{ $ref->{accno} } = $key;
2863 push @{ $self->{"${module}_links"}{$key} },
2864 { accno => $ref->{accno},
2865 description => $ref->{description},
2866 taxkey => $ref->{taxkey_id},
2867 tax_id => $ref->{tax_id} };
2869 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2875 # get taxkeys and description
2876 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2877 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2879 if (($module eq "AP") || ($module eq "AR")) {
2880 # get tax rates and description
2881 $query = qq|SELECT * FROM tax|;
2882 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2888 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2889 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2890 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2891 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2893 d.description AS department,
2896 JOIN $table c ON (a.${table}_id = c.id)
2897 LEFT JOIN employee e ON (e.id = a.employee_id)
2898 LEFT JOIN department d ON (d.id = a.department_id)
2900 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2902 foreach my $key (keys %$ref) {
2903 $self->{$key} = $ref->{$key};
2906 my $transdate = "current_date";
2907 if ($self->{transdate}) {
2908 $transdate = $dbh->quote($self->{transdate});
2911 # now get the account numbers
2912 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2914 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2916 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2917 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2920 $sth = $dbh->prepare($query);
2921 do_statement($self, $sth, $query, "%$module%");
2923 $self->{accounts} = "";
2924 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2926 foreach my $key (split(/:/, $ref->{link})) {
2927 if ($key =~ /\Q$module\E/) {
2929 # cross reference for keys
2930 $xkeyref{ $ref->{accno} } = $key;
2932 push @{ $self->{"${module}_links"}{$key} },
2933 { accno => $ref->{accno},
2934 description => $ref->{description},
2935 taxkey => $ref->{taxkey_id},
2936 tax_id => $ref->{tax_id} };
2938 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2944 # get amounts from individual entries
2947 c.accno, c.description,
2948 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2952 LEFT JOIN chart c ON (c.id = a.chart_id)
2953 LEFT JOIN project p ON (p.id = a.project_id)
2954 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2955 WHERE (tk.taxkey_id=a.taxkey) AND
2956 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2957 THEN tk.chart_id = a.chart_id
2960 OR (c.link='%tax%')) AND
2961 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2962 WHERE a.trans_id = ?
2963 AND a.fx_transaction = '0'
2964 ORDER BY a.acc_trans_id, a.transdate|;
2965 $sth = $dbh->prepare($query);
2966 do_statement($self, $sth, $query, $self->{id});
2968 # get exchangerate for currency
2969 $self->{exchangerate} =
2970 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2973 # store amounts in {acc_trans}{$key} for multiple accounts
2974 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2975 $ref->{exchangerate} =
2976 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2977 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2980 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2981 $ref->{amount} *= -1;
2983 $ref->{index} = $index;
2985 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2991 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;
3003 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
3004 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
3005 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
3007 $ref = selectfirst_hashref_query($self, $dbh, $query);
3008 map { $self->{$_} = $ref->{$_} } keys %$ref;
3010 if ($self->{"$self->{vc}_id"}) {
3012 # only setup currency
3013 ($self->{currency}) = split(/:/, $self->{currencies});
3017 $self->lastname_used($dbh, $myconfig, $table, $module);
3019 # get exchangerate for currency
3020 $self->{exchangerate} =
3021 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3027 $main::lxdebug->leave_sub();
3031 $main::lxdebug->enter_sub();
3033 my ($self, $dbh, $myconfig, $table, $module) = @_;
3037 $table = $table eq "customer" ? "customer" : "vendor";
3038 my %column_map = ("a.curr" => "currency",
3039 "a.${table}_id" => "${table}_id",
3040 "a.department_id" => "department_id",
3041 "d.description" => "department",
3042 "ct.name" => $table,
3043 "current_date + ct.terms" => "duedate",
3046 if ($self->{type} =~ /delivery_order/) {
3047 $arap = 'delivery_orders';
3048 delete $column_map{"a.curr"};
3050 } elsif ($self->{type} =~ /_order/) {
3052 $where = "quotation = '0'";
3054 } elsif ($self->{type} =~ /_quotation/) {
3056 $where = "quotation = '1'";
3058 } elsif ($table eq 'customer') {
3066 $where = "($where) AND" if ($where);
3067 my $query = qq|SELECT MAX(id) FROM $arap
3068 WHERE $where ${table}_id > 0|;
3069 my ($trans_id) = selectrow_query($self, $dbh, $query);
3072 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3073 $query = qq|SELECT $column_spec
3075 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3076 LEFT JOIN department d ON (a.department_id = d.id)
3078 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3080 map { $self->{$_} = $ref->{$_} } values %column_map;
3082 $main::lxdebug->leave_sub();
3086 $main::lxdebug->enter_sub();
3089 my $myconfig = shift || \%::myconfig;
3090 my ($thisdate, $days) = @_;
3092 my $dbh = $self->get_standard_dbh($myconfig);
3097 my $dateformat = $myconfig->{dateformat};
3098 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3099 $thisdate = $dbh->quote($thisdate);
3100 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3102 $query = qq|SELECT current_date AS thisdate|;
3105 ($thisdate) = selectrow_query($self, $dbh, $query);
3107 $main::lxdebug->leave_sub();
3113 $main::lxdebug->enter_sub();
3115 my ($self, $string) = @_;
3117 if ($string !~ /%/) {
3118 $string = "%$string%";
3121 $string =~ s/\'/\'\'/g;
3123 $main::lxdebug->leave_sub();
3129 $main::lxdebug->enter_sub();
3131 my ($self, $flds, $new, $count, $numrows) = @_;
3135 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3140 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3142 my $j = $item->{ndx} - 1;
3143 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3147 for $i ($count + 1 .. $numrows) {
3148 map { delete $self->{"${_}_$i"} } @{$flds};
3151 $main::lxdebug->leave_sub();
3155 $main::lxdebug->enter_sub();
3157 my ($self, $myconfig) = @_;
3161 my $dbh = $self->dbconnect_noauto($myconfig);
3163 my $query = qq|DELETE FROM status
3164 WHERE (formname = ?) AND (trans_id = ?)|;
3165 my $sth = prepare_query($self, $dbh, $query);
3167 if ($self->{formname} =~ /(check|receipt)/) {
3168 for $i (1 .. $self->{rowcount}) {
3169 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3172 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3176 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3177 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3179 my %queued = split / /, $self->{queued};
3182 if ($self->{formname} =~ /(check|receipt)/) {
3184 # this is a check or receipt, add one entry for each lineitem
3185 my ($accno) = split /--/, $self->{account};
3186 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3187 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3188 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3189 $sth = prepare_query($self, $dbh, $query);
3191 for $i (1 .. $self->{rowcount}) {
3192 if ($self->{"checked_$i"}) {
3193 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3199 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3200 VALUES (?, ?, ?, ?, ?)|;
3201 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3202 $queued{$self->{formname}}, $self->{formname});
3208 $main::lxdebug->leave_sub();
3212 $main::lxdebug->enter_sub();
3214 my ($self, $dbh) = @_;
3216 my ($query, $printed, $emailed);
3218 my $formnames = $self->{printed};
3219 my $emailforms = $self->{emailed};
3221 $query = qq|DELETE FROM status
3222 WHERE (formname = ?) AND (trans_id = ?)|;
3223 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3225 # this only applies to the forms
3226 # checks and receipts are posted when printed or queued
3228 if ($self->{queued}) {
3229 my %queued = split / /, $self->{queued};
3231 foreach my $formname (keys %queued) {
3232 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3233 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3235 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3236 VALUES (?, ?, ?, ?, ?)|;
3237 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3239 $formnames =~ s/\Q$self->{formname}\E//;
3240 $emailforms =~ s/\Q$self->{formname}\E//;
3245 # save printed, emailed info
3246 $formnames =~ s/^ +//g;
3247 $emailforms =~ s/^ +//g;
3250 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3251 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3253 foreach my $formname (keys %status) {
3254 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3255 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3257 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3258 VALUES (?, ?, ?, ?)|;
3259 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3262 $main::lxdebug->leave_sub();
3266 # $main::locale->text('SAVED')
3267 # $main::locale->text('DELETED')
3268 # $main::locale->text('ADDED')
3269 # $main::locale->text('PAYMENT POSTED')
3270 # $main::locale->text('POSTED')
3271 # $main::locale->text('POSTED AS NEW')
3272 # $main::locale->text('ELSE')
3273 # $main::locale->text('SAVED FOR DUNNING')
3274 # $main::locale->text('DUNNING STARTED')
3275 # $main::locale->text('PRINTED')
3276 # $main::locale->text('MAILED')
3277 # $main::locale->text('SCREENED')
3278 # $main::locale->text('CANCELED')
3279 # $main::locale->text('invoice')
3280 # $main::locale->text('proforma')
3281 # $main::locale->text('sales_order')
3282 # $main::locale->text('pick_list')
3283 # $main::locale->text('purchase_order')
3284 # $main::locale->text('bin_list')
3285 # $main::locale->text('sales_quotation')
3286 # $main::locale->text('request_quotation')
3289 $main::lxdebug->enter_sub();
3292 my $dbh = shift || $self->get_standard_dbh;
3294 if(!exists $self->{employee_id}) {
3295 &get_employee($self, $dbh);
3299 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3300 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3301 my @values = (conv_i($self->{id}), $self->{login},
3302 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3303 do_query($self, $dbh, $query, @values);
3307 $main::lxdebug->leave_sub();
3311 $main::lxdebug->enter_sub();
3313 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3314 my ($orderBy, $desc) = split(/\-\-/, $order);
3315 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3318 if ($trans_id ne "") {
3320 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 | .
3321 qq|FROM history_erp h | .
3322 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3323 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3326 my $sth = $dbh->prepare($query) || $self->dberror($query);
3328 $sth->execute() || $self->dberror("$query");
3330 while(my $hash_ref = $sth->fetchrow_hashref()) {
3331 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3332 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3333 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3334 $tempArray[$i++] = $hash_ref;
3336 $main::lxdebug->leave_sub() and return \@tempArray
3337 if ($i > 0 && $tempArray[0] ne "");
3339 $main::lxdebug->leave_sub();
3343 sub update_defaults {
3344 $main::lxdebug->enter_sub();
3346 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3349 if ($provided_dbh) {
3350 $dbh = $provided_dbh;
3352 $dbh = $self->dbconnect_noauto($myconfig);
3354 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3355 my $sth = $dbh->prepare($query);
3357 $sth->execute || $self->dberror($query);
3358 my ($var) = $sth->fetchrow_array;
3361 if ($var =~ m/\d+$/) {
3362 my $new_var = (substr $var, $-[0]) * 1 + 1;
3363 my $len_diff = length($var) - $-[0] - length($new_var);
3364 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3370 $query = qq|UPDATE defaults SET $fld = ?|;
3371 do_query($self, $dbh, $query, $var);
3373 if (!$provided_dbh) {
3378 $main::lxdebug->leave_sub();
3383 sub update_business {
3384 $main::lxdebug->enter_sub();
3386 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3389 if ($provided_dbh) {
3390 $dbh = $provided_dbh;
3392 $dbh = $self->dbconnect_noauto($myconfig);
3395 qq|SELECT customernumberinit FROM business
3396 WHERE id = ? FOR UPDATE|;
3397 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3399 return undef unless $var;
3401 if ($var =~ m/\d+$/) {
3402 my $new_var = (substr $var, $-[0]) * 1 + 1;
3403 my $len_diff = length($var) - $-[0] - length($new_var);
3404 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3410 $query = qq|UPDATE business
3411 SET customernumberinit = ?
3413 do_query($self, $dbh, $query, $var, $business_id);
3415 if (!$provided_dbh) {
3420 $main::lxdebug->leave_sub();
3425 sub get_partsgroup {
3426 $main::lxdebug->enter_sub();
3428 my ($self, $myconfig, $p) = @_;
3429 my $target = $p->{target} || 'all_partsgroup';
3431 my $dbh = $self->get_standard_dbh($myconfig);
3433 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3435 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3438 if ($p->{searchitems} eq 'part') {
3439 $query .= qq|WHERE p.inventory_accno_id > 0|;
3441 if ($p->{searchitems} eq 'service') {
3442 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3444 if ($p->{searchitems} eq 'assembly') {
3445 $query .= qq|WHERE p.assembly = '1'|;
3447 if ($p->{searchitems} eq 'labor') {
3448 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3451 $query .= qq|ORDER BY partsgroup|;
3454 $query = qq|SELECT id, partsgroup FROM partsgroup
3455 ORDER BY partsgroup|;
3458 if ($p->{language_code}) {
3459 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3460 t.description AS translation
3462 JOIN parts p ON (p.partsgroup_id = pg.id)
3463 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3464 ORDER BY translation|;
3465 @values = ($p->{language_code});
3468 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3470 $main::lxdebug->leave_sub();
3473 sub get_pricegroup {
3474 $main::lxdebug->enter_sub();
3476 my ($self, $myconfig, $p) = @_;
3478 my $dbh = $self->get_standard_dbh($myconfig);
3480 my $query = qq|SELECT p.id, p.pricegroup
3483 $query .= qq| ORDER BY pricegroup|;
3486 $query = qq|SELECT id, pricegroup FROM pricegroup
3487 ORDER BY pricegroup|;
3490 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3492 $main::lxdebug->leave_sub();
3496 # usage $form->all_years($myconfig, [$dbh])
3497 # return list of all years where bookings found
3500 $main::lxdebug->enter_sub();
3502 my ($self, $myconfig, $dbh) = @_;
3504 $dbh ||= $self->get_standard_dbh($myconfig);
3507 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3508 (SELECT MAX(transdate) FROM acc_trans)|;
3509 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3511 if ($myconfig->{dateformat} =~ /^yy/) {
3512 ($startdate) = split /\W/, $startdate;
3513 ($enddate) = split /\W/, $enddate;
3515 (@_) = split /\W/, $startdate;
3517 (@_) = split /\W/, $enddate;
3522 $startdate = substr($startdate,0,4);
3523 $enddate = substr($enddate,0,4);
3525 while ($enddate >= $startdate) {
3526 push @all_years, $enddate--;
3531 $main::lxdebug->leave_sub();
3535 $main::lxdebug->enter_sub();
3539 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3541 $main::lxdebug->leave_sub();
3545 $main::lxdebug->enter_sub();
3550 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3552 $main::lxdebug->leave_sub();
3555 sub prepare_for_printing {
3558 $self->{templates} ||= $::myconfig{templates};
3559 $self->{formname} ||= $self->{type};
3560 $self->{media} ||= 'email';
3562 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3564 # set shipto from billto unless set
3565 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3566 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3567 $self->{shiptoname} = $::myconfig{company};
3568 $self->{shiptostreet} = $::myconfig{address};
3571 my $language = $self->{language} ? '_' . $self->{language} : '';
3573 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3574 if ($self->{language_id}) {
3575 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3577 $output_dateformat = $::myconfig{dateformat};
3578 $output_numberformat = $::myconfig{numberformat};
3579 $output_longdates = 1;
3582 # Retrieve accounts for tax calculation.
3583 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3585 if ($self->{type} =~ /_delivery_order$/) {
3586 DO->order_details();
3587 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3588 OE->order_details(\%::myconfig, $self);
3590 IS->invoice_details(\%::myconfig, $self, $::locale);
3593 # Chose extension & set source file name
3594 my $extension = 'html';
3595 if ($self->{format} eq 'postscript') {
3596 $self->{postscript} = 1;
3598 } elsif ($self->{"format"} =~ /pdf/) {
3600 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3601 } elsif ($self->{"format"} =~ /opendocument/) {
3602 $self->{opendocument} = 1;
3604 } elsif ($self->{"format"} =~ /excel/) {
3609 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3610 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3611 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3614 $self->format_dates($output_dateformat, $output_longdates,
3615 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3616 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3617 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3619 $self->reformat_numbers($output_numberformat, 2,
3620 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3621 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3623 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3625 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3627 if (scalar @{ $cvar_date_fields }) {
3628 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3631 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3632 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3639 my ($self, $dateformat, $longformat, @indices) = @_;
3641 $dateformat ||= $::myconfig{dateformat};
3643 foreach my $idx (@indices) {
3644 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3645 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3646 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3650 next unless defined $self->{$idx};
3652 if (!ref($self->{$idx})) {
3653 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3655 } elsif (ref($self->{$idx}) eq "ARRAY") {
3656 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3657 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3663 sub reformat_numbers {
3664 my ($self, $numberformat, $places, @indices) = @_;
3666 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3668 foreach my $idx (@indices) {
3669 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3670 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3671 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3675 next unless defined $self->{$idx};
3677 if (!ref($self->{$idx})) {
3678 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3680 } elsif (ref($self->{$idx}) eq "ARRAY") {
3681 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3682 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3687 my $saved_numberformat = $::myconfig{numberformat};
3688 $::myconfig{numberformat} = $numberformat;
3690 foreach my $idx (@indices) {
3691 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3692 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3693 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3697 next unless defined $self->{$idx};
3699 if (!ref($self->{$idx})) {
3700 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3702 } elsif (ref($self->{$idx}) eq "ARRAY") {
3703 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3704 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3709 $::myconfig{numberformat} = $saved_numberformat;
3718 SL::Form.pm - main data object.
3722 This is the main data object of Lx-Office.
3723 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3724 Points of interest for a beginner are:
3726 - $form->error - renders a generic error in html. accepts an error message
3727 - $form->get_standard_dbh - returns a database connection for the
3729 =head1 SPECIAL FUNCTIONS
3731 =head2 C<_store_value()>
3733 parses a complex var name, and stores it in the form.
3736 $form->_store_value($key, $value);
3738 keys must start with a string, and can contain various tokens.
3739 supported key structures are:
3742 simple key strings work as expected
3747 separating two keys by a dot (.) will result in a hash lookup for the inner value
3748 this is similar to the behaviour of java and templating mechanisms.
3750 filter.description => $form->{filter}->{description}
3752 3. array+hashref access
3754 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3755 using [+] instead of [] will force a new array index. this is useful for recurring
3756 data structures like part lists. put a [+] into the first varname, and use [] on the
3759 repeating these names in your template:
3762 invoice.items[].parts_id
3766 $form->{invoice}->{items}->[
3780 using brackets at the end of a name will result in a pure array to be created.
3781 note that you mustn't use [+], which is reserved for array+hash access and will
3782 result in undefined behaviour in array context.
3784 filter.status[] => $form->{status}->[ val1, val2, ... ]
3786 =head2 C<update_business> PARAMS
3789 \%config, - config hashref
3790 $business_id, - business id
3791 $dbh - optional database handle
3793 handles business (thats customer/vendor types) sequences.
3795 special behaviour for empty strings in customerinitnumber field:
3796 will in this case not increase the value, and return undef.
3798 =head2 C<redirect_header> $url
3800 Generates a HTTP redirection header for the new C<$url>. Constructs an
3801 absolute URL including scheme, host name and port. If C<$url> is a
3802 relative URL then it is considered relative to Lx-Office base URL.
3804 This function C<die>s if headers have already been created with
3805 C<$::form-E<gt>header>.
3809 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3810 print $::form->redirect_header('http://www.lx-office.org/');
3814 Generates a general purpose http/html header and includes most of the scripts
3815 ans stylesheets needed.
3817 Only one header will be generated. If the method was already called in this
3818 request it will not output anything and return undef. Also if no
3819 HTTP_USER_AGENT is found, no header is generated.
3821 Although header does not accept parameters itself, it will honor special
3822 hashkeys of its Form instance:
3830 If one of these is set, a http-equiv refresh is generated. Missing parameters
3831 default to 3 seconds and the refering url.
3837 If these are arrayrefs the contents will be inlined into the header.
3841 If true, a css snippet will be generated that sets the page in landscape mode.
3845 Used to override the default favicon.
3849 A html page title will be generated from this