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 #======================================================================
66 use List::Util qw(first max min sum);
67 use List::MoreUtils qw(all any apply);
74 disconnect_standard_dbh();
77 sub disconnect_standard_dbh {
78 return unless $standard_dbh;
79 $standard_dbh->disconnect();
84 $main::lxdebug->enter_sub(2);
90 my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
95 $curr = \ $self->{ shift @tokens };
99 my $sep = shift @tokens;
100 my $key = shift @tokens;
102 $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]';
103 $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
104 $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
105 $curr = \ $$curr->{$key}
110 $main::lxdebug->leave_sub(2);
116 $main::lxdebug->enter_sub(2);
121 my @pairs = split(/&/, $input);
124 my ($key, $value) = split(/=/, $_, 2);
125 $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key);
128 $main::lxdebug->leave_sub(2);
131 sub _request_to_hash {
132 $main::lxdebug->enter_sub(2);
138 if (!$ENV{'CONTENT_TYPE'}
139 || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
141 $self->_input_to_hash($input);
143 $main::lxdebug->leave_sub(2);
147 my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
149 my $boundary = '--' . $1;
151 foreach my $line (split m/\n/, $input) {
152 last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
154 if (($line eq $boundary) || ($line eq "$boundary\r")) {
155 ${ $previous } =~ s|\r?\n$|| if $previous;
161 $content_type = "text/plain";
168 next unless $boundary_found;
170 if (!$headers_done) {
171 $line =~ s/[\r\n]*$//;
178 if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
179 if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
181 substr $line, $-[0], $+[0] - $-[0], "";
184 if ($line =~ m|name\s*=\s*"(.*?)"|i) {
186 substr $line, $-[0], $+[0] - $-[0], "";
189 $previous = _store_value($uploads, $name, '') if ($name);
190 $self->{FILENAME} = $filename if ($filename);
195 if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
202 next unless $previous;
204 ${ $previous } .= "${line}\n";
207 ${ $previous } =~ s|\r?\n$|| if $previous;
209 $main::lxdebug->leave_sub(2);
214 sub _recode_recursively {
215 $main::lxdebug->enter_sub();
216 my ($iconv, $param) = @_;
218 if (any { ref $param eq $_ } qw(Form HASH)) {
219 foreach my $key (keys %{ $param }) {
220 if (!ref $param->{$key}) {
221 # Workaround for a bug: converting $param->{$key} directly
222 # leads to 'undef'. I don't know why. Converting a copy works,
224 $param->{$key} = $iconv->convert("" . $param->{$key});
226 _recode_recursively($iconv, $param->{$key});
230 } elsif (ref $param eq 'ARRAY') {
231 foreach my $idx (0 .. scalar(@{ $param }) - 1) {
232 if (!ref $param->[$idx]) {
233 # Workaround for a bug: converting $param->[$idx] directly
234 # leads to 'undef'. I don't know why. Converting a copy works,
236 $param->[$idx] = $iconv->convert("" . $param->[$idx]);
238 _recode_recursively($iconv, $param->[$idx]);
242 $main::lxdebug->leave_sub();
246 $main::lxdebug->enter_sub();
252 if ($LXDebug::watch_form) {
253 require SL::Watchdog;
254 tie %{ $self }, 'SL::Watchdog';
259 $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
260 $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0];
263 if ($ENV{CONTENT_LENGTH}) {
265 read STDIN, $content, $ENV{CONTENT_LENGTH};
266 $uploads = $self->_request_to_hash($content);
269 my $db_charset = $::lx_office_conf{system}->{dbcharset};
270 $db_charset ||= Common::DEFAULT_CHARSET;
272 my $encoding = $self->{INPUT_ENCODING} || $db_charset;
273 delete $self->{INPUT_ENCODING};
275 _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self);
277 map { $self->{$_} = $uploads->{$_} } keys %{ $uploads } if $uploads;
279 #$self->{version} = "2.6.1"; # Old hardcoded but secure style
280 open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file
281 $self->{version} = <VERSION_FILE>;
283 $self->{version} =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code.
285 $main::lxdebug->leave_sub();
290 sub _flatten_variables_rec {
291 $main::lxdebug->enter_sub(2);
300 if ('' eq ref $curr->{$key}) {
301 @result = ({ 'key' => $prefix . $key, 'value' => $curr->{$key} });
303 } elsif ('HASH' eq ref $curr->{$key}) {
304 foreach my $hash_key (sort keys %{ $curr->{$key} }) {
305 push @result, $self->_flatten_variables_rec($curr->{$key}, $prefix . $key . '.', $hash_key);
309 foreach my $idx (0 .. scalar @{ $curr->{$key} } - 1) {
310 my $first_array_entry = 1;
312 foreach my $hash_key (sort keys %{ $curr->{$key}->[$idx] }) {
313 push @result, $self->_flatten_variables_rec($curr->{$key}->[$idx], $prefix . $key . ($first_array_entry ? '[+].' : '[].'), $hash_key);
314 $first_array_entry = 0;
319 $main::lxdebug->leave_sub(2);
324 sub flatten_variables {
325 $main::lxdebug->enter_sub(2);
333 push @variables, $self->_flatten_variables_rec($self, '', $_);
336 $main::lxdebug->leave_sub(2);
341 sub flatten_standard_variables {
342 $main::lxdebug->enter_sub(2);
345 my %skip_keys = map { $_ => 1 } (qw(login password header stylesheet titlebar version), @_);
349 foreach (grep { ! $skip_keys{$_} } keys %{ $self }) {
350 push @variables, $self->_flatten_variables_rec($self, '', $_);
353 $main::lxdebug->leave_sub(2);
359 $main::lxdebug->enter_sub();
365 map { print "$_ = $self->{$_}\n" } (sort keys %{$self});
367 $main::lxdebug->leave_sub();
371 $main::lxdebug->enter_sub(2);
374 my $password = $self->{password};
376 $self->{password} = 'X' x 8;
378 local $Data::Dumper::Sortkeys = 1;
379 my $output = Dumper($self);
381 $self->{password} = $password;
383 $main::lxdebug->leave_sub(2);
389 $main::lxdebug->enter_sub(2);
391 my ($self, $str) = @_;
393 $str = Encode::encode('utf-8-strict', $str) if $::locale->is_utf8;
394 $str =~ s/([^a-zA-Z0-9_.:-])/sprintf("%%%02x", ord($1))/ge;
396 $main::lxdebug->leave_sub(2);
402 $main::lxdebug->enter_sub(2);
404 my ($self, $str) = @_;
409 $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
410 $str = Encode::decode('utf-8-strict', $str) if $::locale->is_utf8;
412 $main::lxdebug->leave_sub(2);
418 $main::lxdebug->enter_sub();
419 my ($self, $str) = @_;
421 if ($str && !ref($str)) {
422 $str =~ s/\"/"/g;
425 $main::lxdebug->leave_sub();
431 $main::lxdebug->enter_sub();
432 my ($self, $str) = @_;
434 if ($str && !ref($str)) {
435 $str =~ s/"/\"/g;
438 $main::lxdebug->leave_sub();
444 $main::lxdebug->enter_sub();
448 map({ print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_);
450 for (sort keys %$self) {
451 next if (($_ eq "header") || (ref($self->{$_}) ne ""));
452 print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n");
455 $main::lxdebug->leave_sub();
459 my ($self, $code) = @_;
460 local $self->{__ERROR_HANDLER} = sub { die({ error => $_[0] }) };
465 $main::lxdebug->enter_sub();
467 $main::lxdebug->show_backtrace();
469 my ($self, $msg) = @_;
471 if ($self->{__ERROR_HANDLER}) {
472 $self->{__ERROR_HANDLER}->($msg);
474 } elsif ($ENV{HTTP_USER_AGENT}) {
476 $self->show_generic_error($msg);
479 print STDERR "Error: $msg\n";
483 $main::lxdebug->leave_sub();
487 $main::lxdebug->enter_sub();
489 my ($self, $msg) = @_;
491 if ($ENV{HTTP_USER_AGENT}) {
494 if (!$self->{header}) {
500 <p class="message_ok"><b>$msg</b></p>
502 <script type="text/javascript">
504 // If JavaScript is enabled, the whole thing will be reloaded.
505 // The reason is: When one changes his menu setup (HTML / XUL / CSS ...)
506 // it now loads the correct code into the browser instead of do nothing.
507 setTimeout("top.frames.location.href='login.pl'",500);
516 if ($self->{info_function}) {
517 &{ $self->{info_function} }($msg);
523 $main::lxdebug->leave_sub();
526 # calculates the number of rows in a textarea based on the content and column number
527 # can be capped with maxrows
529 $main::lxdebug->enter_sub();
530 my ($self, $str, $cols, $maxrows, $minrows) = @_;
534 my $rows = sum map { int((length() - 2) / $cols) + 1 } split /\r/, $str;
537 $main::lxdebug->leave_sub();
539 return max(min($rows, $maxrows), $minrows);
543 $main::lxdebug->enter_sub();
545 my ($self, $msg) = @_;
547 $self->error("$msg\n" . $DBI::errstr);
549 $main::lxdebug->leave_sub();
553 $main::lxdebug->enter_sub();
555 my ($self, $name, $msg) = @_;
558 foreach my $part (split m/\./, $name) {
559 if (!$curr->{$part} || ($curr->{$part} =~ /^\s*$/)) {
562 $curr = $curr->{$part};
565 $main::lxdebug->leave_sub();
568 sub _get_request_uri {
571 return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
573 my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http';
574 my $port = $ENV{SERVER_PORT} || '';
575 $port = undef if (($scheme eq 'http' ) && ($port == 80))
576 || (($scheme eq 'https') && ($port == 443));
578 my $uri = URI->new("${scheme}://");
579 $uri->scheme($scheme);
581 $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
582 $uri->path_query($ENV{REQUEST_URI});
588 sub _add_to_request_uri {
591 my $relative_new_path = shift;
592 my $request_uri = shift || $self->_get_request_uri;
593 my $relative_new_uri = URI->new($relative_new_path);
594 my @request_segments = $request_uri->path_segments;
596 my $new_uri = $request_uri->clone;
597 $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments);
602 sub create_http_response {
603 $main::lxdebug->enter_sub();
608 my $cgi = $main::cgi;
609 $cgi ||= CGI->new('');
612 if (defined $main::auth) {
613 my $uri = $self->_get_request_uri;
614 my @segments = $uri->path_segments;
616 $uri->path_segments(@segments);
618 my $session_cookie_value = $main::auth->get_session_id();
620 if ($session_cookie_value) {
621 $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
622 '-value' => $session_cookie_value,
623 '-path' => $uri->path,
624 '-secure' => $ENV{HTTPS});
628 my %cgi_params = ('-type' => $params{content_type});
629 $cgi_params{'-charset'} = $params{charset} if ($params{charset});
630 $cgi_params{'-cookie'} = $session_cookie if ($session_cookie);
632 my $output = $cgi->header(%cgi_params);
634 $main::lxdebug->leave_sub();
641 $::lxdebug->enter_sub;
643 # extra code is currently only used by menuv3 and menuv4 to set their css.
644 # it is strongly deprecated, and will be changed in a future version.
645 my ($self, $extra_code) = @_;
646 my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
649 $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
651 $self->{favicon} ||= "favicon.ico";
652 $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title};
655 if ($self->{refresh_url} || $self->{refresh_time}) {
656 my $refresh_time = $self->{refresh_time} || 3;
657 my $refresh_url = $self->{refresh_url} || $ENV{REFERER};
658 push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
661 push @header, "<link rel='stylesheet' href='css/$_' type='text/css' title='Lx-Office stylesheet'>"
662 for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets};
664 push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
665 push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
666 push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
667 '<script type="text/javascript" src="js/common.js"></script>',
668 '<style type="text/css">@import url(js/jscalendar/calendar-win2k-1.css);</style>',
669 '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
670 '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
671 '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
672 '<script type="text/javascript" src="js/part_selection.js"></script>';
673 push @header, $self->{javascript} if $self->{javascript};
674 push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
675 push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
676 push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
677 join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title};
679 # if there is a title, we put some JavaScript in to the page, wich writes a
680 # meaningful title-tag for our frameset.
682 if ($self->{title}) {
684 <script type="text/javascript">
686 // Write a meaningful title-tag for our frameset.
687 top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
693 print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
694 print "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01//EN' 'http://www.w3.org/TR/html4/strict.dtd'>\n"
695 if $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/; # Other browsers may choke on menu scripts with DOCTYPE.
699 <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
700 <title>$self->{titlebar}</title>
702 print " $_\n" for @header;
704 <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css" />
705 <meta name="robots" content="noindex,nofollow" />
706 <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
707 <script type="text/javascript" src="js/tabcontent.js">
709 /***********************************************
710 * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
711 * This notice MUST stay intact for legal use
712 * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
713 ***********************************************/
722 $::lxdebug->leave_sub;
725 sub ajax_response_header {
726 $main::lxdebug->enter_sub();
730 my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
731 my $cgi = $main::cgi || CGI->new('');
732 my $output = $cgi->header('-charset' => $db_charset);
734 $main::lxdebug->leave_sub();
739 sub redirect_header {
743 my $base_uri = $self->_get_request_uri;
744 my $new_uri = URI->new_abs($new_url, $base_uri);
746 die "Headers already sent" if $::self->{header};
749 my $cgi = $main::cgi || CGI->new('');
750 return $cgi->redirect($new_uri);
753 sub set_standard_title {
754 $::lxdebug->enter_sub;
757 $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
758 $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
759 $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
761 $::lxdebug->leave_sub;
764 sub _prepare_html_template {
765 $main::lxdebug->enter_sub();
767 my ($self, $file, $additional_params) = @_;
770 if (!%::myconfig || !$::myconfig{"countrycode"}) {
771 $language = $::lx_office_conf{system}->{language};
773 $language = $main::myconfig{"countrycode"};
775 $language = "de" unless ($language);
777 if (-f "templates/webpages/${file}.html") {
778 if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
779 my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
780 "Please re-run 'locales.pl' in 'locale/${language}'.";
781 print(qq|<pre>$info</pre>|);
785 $file = "templates/webpages/${file}.html";
788 my $info = "Web page template '${file}' not found.\n";
789 print qq|<pre>$info</pre>|;
793 if ($self->{"DEBUG"}) {
794 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
797 if ($additional_params->{"DEBUG"}) {
798 $additional_params->{"DEBUG"} =
799 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
802 if (%main::myconfig) {
803 $::myconfig{jsc_dateformat} = apply {
807 } $::myconfig{"dateformat"};
808 $additional_params->{"myconfig"} ||= \%::myconfig;
809 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
812 $additional_params->{"conf_dbcharset"} = $::lx_office_conf{system}->{dbcharset};
813 $additional_params->{"conf_webdav"} = $::lx_office_conf{features}->{webdav};
814 $additional_params->{"conf_lizenzen"} = $::lx_office_conf{features}->{lizenzen};
815 $additional_params->{"conf_latex_templates"} = $::lx_office_conf{print_templates}->{latex};
816 $additional_params->{"conf_opendocument_templates"} = $::lx_office_conf{print_templates}->{opendocument};
817 $additional_params->{"conf_vertreter"} = $::lx_office_conf{features}->{vertreter};
818 $additional_params->{"conf_show_best_before"} = $::lx_office_conf{features}->{show_best_before};
819 $additional_params->{"conf_parts_image_css"} = $::lx_office_conf{features}->{parts_image_css};
820 $additional_params->{"conf_parts_listing_images"} = $::lx_office_conf{features}->{parts_listing_images};
821 $additional_params->{"conf_parts_show_image"} = $::lx_office_conf{features}->{parts_show_image};
823 if (%main::debug_options) {
824 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
827 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
828 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
829 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
833 $main::lxdebug->leave_sub();
838 sub parse_html_template {
839 $main::lxdebug->enter_sub();
841 my ($self, $file, $additional_params) = @_;
843 $additional_params ||= { };
845 my $real_file = $self->_prepare_html_template($file, $additional_params);
846 my $template = $self->template || $self->init_template;
848 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
851 $template->process($real_file, $additional_params, \$output) || die $template->error;
853 $main::lxdebug->leave_sub();
861 return if $self->template;
863 return $self->template(Template->new({
868 'PLUGIN_BASE' => 'SL::Template::Plugin',
869 'INCLUDE_PATH' => '.:templates/webpages',
870 'COMPILE_EXT' => '.tcc',
871 'COMPILE_DIR' => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
877 $self->{template_object} = shift if @_;
878 return $self->{template_object};
881 sub show_generic_error {
882 $main::lxdebug->enter_sub();
884 my ($self, $error, %params) = @_;
886 if ($self->{__ERROR_HANDLER}) {
887 $self->{__ERROR_HANDLER}->($error);
888 $main::lxdebug->leave_sub();
893 'title_error' => $params{title},
894 'label_error' => $error,
897 if ($params{action}) {
900 map { delete($self->{$_}); } qw(action);
901 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
903 $add_params->{SHOW_BUTTON} = 1;
904 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
905 $add_params->{VARIABLES} = \@vars;
907 } elsif ($params{back_button}) {
908 $add_params->{SHOW_BACK_BUTTON} = 1;
911 $self->{title} = $params{title} if $params{title};
914 print $self->parse_html_template("generic/error", $add_params);
916 print STDERR "Error: $error\n";
918 $main::lxdebug->leave_sub();
923 sub show_generic_information {
924 $main::lxdebug->enter_sub();
926 my ($self, $text, $title) = @_;
929 'title_information' => $title,
930 'label_information' => $text,
933 $self->{title} = $title if ($title);
936 print $self->parse_html_template("generic/information", $add_params);
938 $main::lxdebug->leave_sub();
943 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
944 # changed it to accept an arbitrary number of triggers - sschoeling
946 $main::lxdebug->enter_sub();
949 my $myconfig = shift;
952 # set dateform for jsscript
955 "dd.mm.yy" => "%d.%m.%Y",
956 "dd-mm-yy" => "%d-%m-%Y",
957 "dd/mm/yy" => "%d/%m/%Y",
958 "mm/dd/yy" => "%m/%d/%Y",
959 "mm-dd-yy" => "%m-%d-%Y",
960 "yyyy-mm-dd" => "%Y-%m-%d",
963 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
964 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
971 inputField : "| . (shift) . qq|",
972 ifFormat :"$ifFormat",
973 align : "| . (shift) . qq|",
974 button : "| . (shift) . qq|"
980 <script type="text/javascript">
981 <!--| . join("", @triggers) . qq|//-->
985 $main::lxdebug->leave_sub();
988 } #end sub write_trigger
991 $main::lxdebug->enter_sub();
993 my ($self, $msg) = @_;
995 if (!$self->{callback}) {
1001 # my ($script, $argv) = split(/\?/, $self->{callback}, 2);
1002 # $script =~ s|.*/||;
1003 # $script =~ s|[^a-zA-Z0-9_\.]||g;
1004 # exec("perl", "$script", $argv);
1006 print $::form->redirect_header($self->{callback});
1008 $main::lxdebug->leave_sub();
1011 # sort of columns removed - empty sub
1013 $main::lxdebug->enter_sub();
1015 my ($self, @columns) = @_;
1017 $main::lxdebug->leave_sub();
1023 $main::lxdebug->enter_sub(2);
1025 my ($self, $myconfig, $amount, $places, $dash) = @_;
1027 if ($amount eq "") {
1031 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1033 my $neg = ($amount =~ s/^-//);
1034 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1036 if (defined($places) && ($places ne '')) {
1042 my ($actual_places) = ($amount =~ /\.(\d+)/);
1043 $actual_places = length($actual_places);
1044 $places = $actual_places > $places ? $actual_places : $places;
1047 $amount = $self->round_amount($amount, $places);
1050 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1051 my @p = split(/\./, $amount); # split amount at decimal point
1053 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1056 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1059 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1060 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1061 ($neg ? "-$amount" : "$amount" ) ;
1065 $main::lxdebug->leave_sub(2);
1069 sub format_amount_units {
1070 $main::lxdebug->enter_sub();
1075 my $myconfig = \%main::myconfig;
1076 my $amount = $params{amount} * 1;
1077 my $places = $params{places};
1078 my $part_unit_name = $params{part_unit};
1079 my $amount_unit_name = $params{amount_unit};
1080 my $conv_units = $params{conv_units};
1081 my $max_places = $params{max_places};
1083 if (!$part_unit_name) {
1084 $main::lxdebug->leave_sub();
1088 AM->retrieve_all_units();
1089 my $all_units = $main::all_units;
1091 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1092 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1095 if (!scalar @{ $conv_units }) {
1096 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1097 $main::lxdebug->leave_sub();
1101 my $part_unit = $all_units->{$part_unit_name};
1102 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1104 $amount *= $conv_unit->{factor};
1109 foreach my $unit (@$conv_units) {
1110 my $last = $unit->{name} eq $part_unit->{name};
1112 $num = int($amount / $unit->{factor});
1113 $amount -= $num * $unit->{factor};
1116 if ($last ? $amount : $num) {
1117 push @values, { "unit" => $unit->{name},
1118 "amount" => $last ? $amount / $unit->{factor} : $num,
1119 "places" => $last ? $places : 0 };
1126 push @values, { "unit" => $part_unit_name,
1131 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1133 $main::lxdebug->leave_sub();
1139 $main::lxdebug->enter_sub(2);
1144 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1145 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1146 $input =~ s/\#\#/\#/g;
1148 $main::lxdebug->leave_sub(2);
1156 $main::lxdebug->enter_sub(2);
1158 my ($self, $myconfig, $amount) = @_;
1160 if ( ($myconfig->{numberformat} eq '1.000,00')
1161 || ($myconfig->{numberformat} eq '1000,00')) {
1166 if ($myconfig->{numberformat} eq "1'000.00") {
1172 $main::lxdebug->leave_sub(2);
1174 return ($amount * 1);
1178 $main::lxdebug->enter_sub(2);
1180 my ($self, $amount, $places) = @_;
1183 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1185 # Round amounts to eight places before rounding to the requested
1186 # number of places. This gets rid of errors due to internal floating
1187 # point representation.
1188 $amount = $self->round_amount($amount, 8) if $places < 8;
1189 $amount = $amount * (10**($places));
1190 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1192 $main::lxdebug->leave_sub(2);
1194 return $round_amount;
1198 sub parse_template {
1199 $main::lxdebug->enter_sub();
1201 my ($self, $myconfig) = @_;
1206 my $userspath = $::lx_office_conf{paths}->{userspath};
1208 $self->{"cwd"} = getcwd();
1209 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1214 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1215 $template_type = 'OpenDocument';
1216 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1218 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1219 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1220 $template_type = 'LaTeX';
1221 $ext_for_format = 'pdf';
1223 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1224 $template_type = 'HTML';
1225 $ext_for_format = 'html';
1227 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1228 $template_type = 'XML';
1229 $ext_for_format = 'xml';
1231 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1232 $template_type = 'XML';
1234 } elsif ( $self->{"format"} =~ /excel/i ) {
1235 $template_type = 'Excel';
1236 $ext_for_format = 'xls';
1238 } elsif ( defined $self->{'format'}) {
1239 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1241 } elsif ( $self->{'format'} eq '' ) {
1242 $self->error("No Outputformat given: $self->{'format'}");
1244 } else { #Catch the rest
1245 $self->error("Outputformat not defined: $self->{'format'}");
1248 my $template = SL::Template::create(type => $template_type,
1249 file_name => $self->{IN},
1251 myconfig => $myconfig,
1252 userspath => $userspath);
1254 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1255 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1257 if (!$self->{employee_id}) {
1258 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1261 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1262 map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1264 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1266 # OUT is used for the media, screen, printer, email
1267 # for postscript we store a copy in a temporary file
1269 my $prepend_userspath;
1271 if (!$self->{tmpfile}) {
1272 $self->{tmpfile} = "${fileid}.$self->{IN}";
1273 $prepend_userspath = 1;
1276 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1278 $self->{tmpfile} =~ s|.*/||;
1279 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1280 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1282 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1283 $out = $self->{OUT};
1284 $self->{OUT} = ">$self->{tmpfile}";
1290 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1291 $result = $template->parse(*OUT);
1296 $result = $template->parse(*STDOUT);
1301 $self->error("$self->{IN} : " . $template->get_error());
1304 if ($self->{media} eq 'file') {
1305 copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1307 chdir("$self->{cwd}");
1309 $::lxdebug->leave_sub();
1314 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1316 if ($self->{media} eq 'email') {
1318 my $mail = new Mailer;
1320 map { $mail->{$_} = $self->{$_} }
1321 qw(cc bcc subject message version format);
1322 $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1323 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1324 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1325 $mail->{fileid} = "$fileid.";
1326 $myconfig->{signature} =~ s/\r//g;
1328 # if we send html or plain text inline
1329 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1330 $mail->{contenttype} = "text/html";
1332 $mail->{message} =~ s/\r//g;
1333 $mail->{message} =~ s/\n/<br>\n/g;
1334 $myconfig->{signature} =~ s/\n/<br>\n/g;
1335 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1337 open(IN, $self->{tmpfile})
1338 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1340 $mail->{message} .= $_;
1347 if (!$self->{"do_not_attach"}) {
1348 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1349 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1350 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1351 "name" => $attachment_name }];
1354 $mail->{message} =~ s/\r//g;
1355 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1359 my $err = $mail->send();
1360 $self->error($self->cleanup . "$err") if ($err);
1364 $self->{OUT} = $out;
1366 my $numbytes = (-s $self->{tmpfile});
1367 open(IN, $self->{tmpfile})
1368 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1371 $self->{copies} = 1 unless $self->{media} eq 'printer';
1373 chdir("$self->{cwd}");
1374 #print(STDERR "Kopien $self->{copies}\n");
1375 #print(STDERR "OUT $self->{OUT}\n");
1376 for my $i (1 .. $self->{copies}) {
1378 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1379 print OUT while <IN>;
1384 $self->{attachment_filename} = ($self->{attachment_filename})
1385 ? $self->{attachment_filename}
1386 : $self->generate_attachment_filename();
1388 # launch application
1389 print qq|Content-Type: | . $template->get_mime_type() . qq|
1390 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1391 Content-Length: $numbytes
1395 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1406 chdir("$self->{cwd}");
1407 $main::lxdebug->leave_sub();
1410 sub get_formname_translation {
1411 $main::lxdebug->enter_sub();
1412 my ($self, $formname) = @_;
1414 $formname ||= $self->{formname};
1416 my %formname_translations = (
1417 bin_list => $main::locale->text('Bin List'),
1418 credit_note => $main::locale->text('Credit Note'),
1419 invoice => $main::locale->text('Invoice'),
1420 pick_list => $main::locale->text('Pick List'),
1421 proforma => $main::locale->text('Proforma Invoice'),
1422 purchase_order => $main::locale->text('Purchase Order'),
1423 request_quotation => $main::locale->text('RFQ'),
1424 sales_order => $main::locale->text('Confirmation'),
1425 sales_quotation => $main::locale->text('Quotation'),
1426 storno_invoice => $main::locale->text('Storno Invoice'),
1427 sales_delivery_order => $main::locale->text('Delivery Order'),
1428 purchase_delivery_order => $main::locale->text('Delivery Order'),
1429 dunning => $main::locale->text('Dunning'),
1432 $main::lxdebug->leave_sub();
1433 return $formname_translations{$formname}
1436 sub get_number_prefix_for_type {
1437 $main::lxdebug->enter_sub();
1441 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1442 : ($self->{type} =~ /_quotation$/) ? 'quo'
1443 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1446 $main::lxdebug->leave_sub();
1450 sub get_extension_for_format {
1451 $main::lxdebug->enter_sub();
1454 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1455 : $self->{format} =~ /postscript/i ? ".ps"
1456 : $self->{format} =~ /opendocument/i ? ".odt"
1457 : $self->{format} =~ /excel/i ? ".xls"
1458 : $self->{format} =~ /html/i ? ".html"
1461 $main::lxdebug->leave_sub();
1465 sub generate_attachment_filename {
1466 $main::lxdebug->enter_sub();
1469 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1470 my $prefix = $self->get_number_prefix_for_type();
1472 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1473 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1475 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1476 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1479 $attachment_filename = "";
1482 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1483 $attachment_filename =~ s|[\s/\\]+|_|g;
1485 $main::lxdebug->leave_sub();
1486 return $attachment_filename;
1489 sub generate_email_subject {
1490 $main::lxdebug->enter_sub();
1493 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1494 my $prefix = $self->get_number_prefix_for_type();
1496 if ($subject && $self->{"${prefix}number"}) {
1497 $subject .= " " . $self->{"${prefix}number"}
1500 $main::lxdebug->leave_sub();
1505 $main::lxdebug->enter_sub();
1509 chdir("$self->{tmpdir}");
1512 if (-f "$self->{tmpfile}.err") {
1513 open(FH, "$self->{tmpfile}.err");
1518 if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1519 $self->{tmpfile} =~ s|.*/||g;
1521 $self->{tmpfile} =~ s/\.\w+$//g;
1522 my $tmpfile = $self->{tmpfile};
1523 unlink(<$tmpfile.*>);
1526 chdir("$self->{cwd}");
1528 $main::lxdebug->leave_sub();
1534 $main::lxdebug->enter_sub();
1536 my ($self, $date, $myconfig) = @_;
1539 if ($date && $date =~ /\D/) {
1541 if ($myconfig->{dateformat} =~ /^yy/) {
1542 ($yy, $mm, $dd) = split /\D/, $date;
1544 if ($myconfig->{dateformat} =~ /^mm/) {
1545 ($mm, $dd, $yy) = split /\D/, $date;
1547 if ($myconfig->{dateformat} =~ /^dd/) {
1548 ($dd, $mm, $yy) = split /\D/, $date;
1553 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1554 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1556 $dd = "0$dd" if ($dd < 10);
1557 $mm = "0$mm" if ($mm < 10);
1559 $date = "$yy$mm$dd";
1562 $main::lxdebug->leave_sub();
1567 # Database routines used throughout
1569 sub _dbconnect_options {
1571 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1578 $main::lxdebug->enter_sub(2);
1580 my ($self, $myconfig) = @_;
1582 # connect to database
1583 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1587 if ($myconfig->{dboptions}) {
1588 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1591 $main::lxdebug->leave_sub(2);
1596 sub dbconnect_noauto {
1597 $main::lxdebug->enter_sub();
1599 my ($self, $myconfig) = @_;
1601 # connect to database
1602 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1606 if ($myconfig->{dboptions}) {
1607 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1610 $main::lxdebug->leave_sub();
1615 sub get_standard_dbh {
1616 $main::lxdebug->enter_sub(2);
1619 my $myconfig = shift || \%::myconfig;
1621 if ($standard_dbh && !$standard_dbh->{Active}) {
1622 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1623 undef $standard_dbh;
1626 $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1628 $main::lxdebug->leave_sub(2);
1630 return $standard_dbh;
1634 $main::lxdebug->enter_sub();
1636 my ($self, $date, $myconfig) = @_;
1637 my $dbh = $self->dbconnect($myconfig);
1639 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1640 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1641 my ($closed) = $sth->fetchrow_array;
1643 $main::lxdebug->leave_sub();
1648 sub update_balance {
1649 $main::lxdebug->enter_sub();
1651 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1653 # if we have a value, go do it
1656 # retrieve balance from table
1657 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1658 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1659 my ($balance) = $sth->fetchrow_array;
1665 $query = "UPDATE $table SET $field = $balance WHERE $where";
1666 do_query($self, $dbh, $query, @values);
1668 $main::lxdebug->leave_sub();
1671 sub update_exchangerate {
1672 $main::lxdebug->enter_sub();
1674 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1676 # some sanity check for currency
1678 $main::lxdebug->leave_sub();
1681 $query = qq|SELECT curr FROM defaults|;
1683 my ($currency) = selectrow_query($self, $dbh, $query);
1684 my ($defaultcurrency) = split m/:/, $currency;
1687 if ($curr eq $defaultcurrency) {
1688 $main::lxdebug->leave_sub();
1692 $query = qq|SELECT e.curr FROM exchangerate e
1693 WHERE e.curr = ? AND e.transdate = ?
1695 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1704 $buy = conv_i($buy, "NULL");
1705 $sell = conv_i($sell, "NULL");
1708 if ($buy != 0 && $sell != 0) {
1709 $set = "buy = $buy, sell = $sell";
1710 } elsif ($buy != 0) {
1711 $set = "buy = $buy";
1712 } elsif ($sell != 0) {
1713 $set = "sell = $sell";
1716 if ($sth->fetchrow_array) {
1717 $query = qq|UPDATE exchangerate
1723 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1724 VALUES (?, $buy, $sell, ?)|;
1727 do_query($self, $dbh, $query, $curr, $transdate);
1729 $main::lxdebug->leave_sub();
1732 sub save_exchangerate {
1733 $main::lxdebug->enter_sub();
1735 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1737 my $dbh = $self->dbconnect($myconfig);
1741 $buy = $rate if $fld eq 'buy';
1742 $sell = $rate if $fld eq 'sell';
1745 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1750 $main::lxdebug->leave_sub();
1753 sub get_exchangerate {
1754 $main::lxdebug->enter_sub();
1756 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1759 unless ($transdate) {
1760 $main::lxdebug->leave_sub();
1764 $query = qq|SELECT curr FROM defaults|;
1766 my ($currency) = selectrow_query($self, $dbh, $query);
1767 my ($defaultcurrency) = split m/:/, $currency;
1769 if ($currency eq $defaultcurrency) {
1770 $main::lxdebug->leave_sub();
1774 $query = qq|SELECT e.$fld FROM exchangerate e
1775 WHERE e.curr = ? AND e.transdate = ?|;
1776 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1780 $main::lxdebug->leave_sub();
1782 return $exchangerate;
1785 sub check_exchangerate {
1786 $main::lxdebug->enter_sub();
1788 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1790 if ($fld !~/^buy|sell$/) {
1791 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1794 unless ($transdate) {
1795 $main::lxdebug->leave_sub();
1799 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1801 if ($currency eq $defaultcurrency) {
1802 $main::lxdebug->leave_sub();
1806 my $dbh = $self->get_standard_dbh($myconfig);
1807 my $query = qq|SELECT e.$fld FROM exchangerate e
1808 WHERE e.curr = ? AND e.transdate = ?|;
1810 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1812 $main::lxdebug->leave_sub();
1814 return $exchangerate;
1817 sub get_all_currencies {
1818 $main::lxdebug->enter_sub();
1821 my $myconfig = shift || \%::myconfig;
1822 my $dbh = $self->get_standard_dbh($myconfig);
1824 my $query = qq|SELECT curr FROM defaults|;
1826 my ($curr) = selectrow_query($self, $dbh, $query);
1827 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1829 $main::lxdebug->leave_sub();
1834 sub get_default_currency {
1835 $main::lxdebug->enter_sub();
1837 my ($self, $myconfig) = @_;
1838 my @currencies = $self->get_all_currencies($myconfig);
1840 $main::lxdebug->leave_sub();
1842 return $currencies[0];
1845 sub set_payment_options {
1846 $main::lxdebug->enter_sub();
1848 my ($self, $myconfig, $transdate) = @_;
1850 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1852 my $dbh = $self->get_standard_dbh($myconfig);
1855 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1856 qq|FROM payment_terms p | .
1859 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1860 $self->{payment_terms}) =
1861 selectrow_query($self, $dbh, $query, $self->{payment_id});
1863 if ($transdate eq "") {
1864 if ($self->{invdate}) {
1865 $transdate = $self->{invdate};
1867 $transdate = $self->{transdate};
1872 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1873 qq|FROM payment_terms|;
1874 ($self->{netto_date}, $self->{skonto_date}) =
1875 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1877 my ($invtotal, $total);
1878 my (%amounts, %formatted_amounts);
1880 if ($self->{type} =~ /_order$/) {
1881 $amounts{invtotal} = $self->{ordtotal};
1882 $amounts{total} = $self->{ordtotal};
1884 } elsif ($self->{type} =~ /_quotation$/) {
1885 $amounts{invtotal} = $self->{quototal};
1886 $amounts{total} = $self->{quototal};
1889 $amounts{invtotal} = $self->{invtotal};
1890 $amounts{total} = $self->{total};
1892 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1894 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1896 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1897 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1898 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1900 foreach (keys %amounts) {
1901 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1902 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1905 if ($self->{"language_id"}) {
1907 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1908 qq|FROM translation_payment_terms t | .
1909 qq|LEFT JOIN language l ON t.language_id = l.id | .
1910 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1911 my ($description_long, $output_numberformat, $output_dateformat,
1912 $output_longdates) =
1913 selectrow_query($self, $dbh, $query,
1914 $self->{"language_id"}, $self->{"payment_id"});
1916 $self->{payment_terms} = $description_long if ($description_long);
1918 if ($output_dateformat) {
1919 foreach my $key (qw(netto_date skonto_date)) {
1921 $main::locale->reformat_date($myconfig, $self->{$key},
1927 if ($output_numberformat &&
1928 ($output_numberformat ne $myconfig->{"numberformat"})) {
1929 my $saved_numberformat = $myconfig->{"numberformat"};
1930 $myconfig->{"numberformat"} = $output_numberformat;
1931 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1932 $myconfig->{"numberformat"} = $saved_numberformat;
1936 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1937 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1938 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1939 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1940 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1941 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1942 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1944 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1946 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1948 $main::lxdebug->leave_sub();
1952 sub get_template_language {
1953 $main::lxdebug->enter_sub();
1955 my ($self, $myconfig) = @_;
1957 my $template_code = "";
1959 if ($self->{language_id}) {
1960 my $dbh = $self->get_standard_dbh($myconfig);
1961 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1962 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1965 $main::lxdebug->leave_sub();
1967 return $template_code;
1970 sub get_printer_code {
1971 $main::lxdebug->enter_sub();
1973 my ($self, $myconfig) = @_;
1975 my $template_code = "";
1977 if ($self->{printer_id}) {
1978 my $dbh = $self->get_standard_dbh($myconfig);
1979 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1980 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1983 $main::lxdebug->leave_sub();
1985 return $template_code;
1989 $main::lxdebug->enter_sub();
1991 my ($self, $myconfig) = @_;
1993 my $template_code = "";
1995 if ($self->{shipto_id}) {
1996 my $dbh = $self->get_standard_dbh($myconfig);
1997 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1998 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1999 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
2002 $main::lxdebug->leave_sub();
2006 $main::lxdebug->enter_sub();
2008 my ($self, $dbh, $id, $module) = @_;
2013 foreach my $item (qw(name department_1 department_2 street zipcode city country
2014 contact cp_gender phone fax email)) {
2015 if ($self->{"shipto$item"}) {
2016 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2018 push(@values, $self->{"shipto${item}"});
2022 if ($self->{shipto_id}) {
2023 my $query = qq|UPDATE shipto set
2025 shiptodepartment_1 = ?,
2026 shiptodepartment_2 = ?,
2032 shiptocp_gender = ?,
2036 WHERE shipto_id = ?|;
2037 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2039 my $query = qq|SELECT * FROM shipto
2040 WHERE shiptoname = ? AND
2041 shiptodepartment_1 = ? AND
2042 shiptodepartment_2 = ? AND
2043 shiptostreet = ? AND
2044 shiptozipcode = ? AND
2046 shiptocountry = ? AND
2047 shiptocontact = ? AND
2048 shiptocp_gender = ? AND
2054 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2057 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2058 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2059 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2060 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2061 do_query($self, $dbh, $query, $id, @values, $module);
2066 $main::lxdebug->leave_sub();
2070 $main::lxdebug->enter_sub();
2072 my ($self, $dbh) = @_;
2074 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2076 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2077 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2078 $self->{"employee_id"} *= 1;
2080 $main::lxdebug->leave_sub();
2083 sub get_employee_data {
2084 $main::lxdebug->enter_sub();
2089 Common::check_params(\%params, qw(prefix));
2090 Common::check_params_x(\%params, qw(id));
2093 $main::lxdebug->leave_sub();
2097 my $myconfig = \%main::myconfig;
2098 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2100 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2103 my $user = User->new($login);
2104 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2106 $self->{$params{prefix} . '_login'} = $login;
2107 $self->{$params{prefix} . '_name'} ||= $login;
2110 $main::lxdebug->leave_sub();
2114 $main::lxdebug->enter_sub();
2116 my ($self, $myconfig, $reference_date) = @_;
2118 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2120 my $dbh = $self->get_standard_dbh($myconfig);
2121 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2122 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2124 $main::lxdebug->leave_sub();
2130 $main::lxdebug->enter_sub();
2132 my ($self, $dbh, $id, $key) = @_;
2134 $key = "all_contacts" unless ($key);
2138 $main::lxdebug->leave_sub();
2143 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2144 qq|FROM contacts | .
2145 qq|WHERE cp_cv_id = ? | .
2146 qq|ORDER BY lower(cp_name)|;
2148 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2150 $main::lxdebug->leave_sub();
2154 $main::lxdebug->enter_sub();
2156 my ($self, $dbh, $key) = @_;
2158 my ($all, $old_id, $where, @values);
2160 if (ref($key) eq "HASH") {
2163 $key = "ALL_PROJECTS";
2165 foreach my $p (keys(%{$params})) {
2167 $all = $params->{$p};
2168 } elsif ($p eq "old_id") {
2169 $old_id = $params->{$p};
2170 } elsif ($p eq "key") {
2171 $key = $params->{$p};
2177 $where = "WHERE active ";
2179 if (ref($old_id) eq "ARRAY") {
2180 my @ids = grep({ $_ } @{$old_id});
2182 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2183 push(@values, @ids);
2186 $where .= " OR (id = ?) ";
2187 push(@values, $old_id);
2193 qq|SELECT id, projectnumber, description, active | .
2196 qq|ORDER BY lower(projectnumber)|;
2198 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2200 $main::lxdebug->leave_sub();
2204 $main::lxdebug->enter_sub();
2206 my ($self, $dbh, $vc_id, $key) = @_;
2208 $key = "all_shipto" unless ($key);
2211 # get shipping addresses
2212 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2214 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2220 $main::lxdebug->leave_sub();
2224 $main::lxdebug->enter_sub();
2226 my ($self, $dbh, $key) = @_;
2228 $key = "all_printers" unless ($key);
2230 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2232 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2234 $main::lxdebug->leave_sub();
2238 $main::lxdebug->enter_sub();
2240 my ($self, $dbh, $params) = @_;
2243 $key = $params->{key};
2244 $key = "all_charts" unless ($key);
2246 my $transdate = quote_db_date($params->{transdate});
2249 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2251 qq|LEFT JOIN taxkeys tk ON | .
2252 qq|(tk.id = (SELECT id FROM taxkeys | .
2253 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2254 qq| ORDER BY startdate DESC LIMIT 1)) | .
2255 qq|ORDER BY c.accno|;
2257 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2259 $main::lxdebug->leave_sub();
2262 sub _get_taxcharts {
2263 $main::lxdebug->enter_sub();
2265 my ($self, $dbh, $params) = @_;
2267 my $key = "all_taxcharts";
2270 if (ref $params eq 'HASH') {
2271 $key = $params->{key} if ($params->{key});
2272 if ($params->{module} eq 'AR') {
2273 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2275 } elsif ($params->{module} eq 'AP') {
2276 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2283 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2285 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2287 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2289 $main::lxdebug->leave_sub();
2293 $main::lxdebug->enter_sub();
2295 my ($self, $dbh, $key) = @_;
2297 $key = "all_taxzones" unless ($key);
2299 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2301 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2303 $main::lxdebug->leave_sub();
2306 sub _get_employees {
2307 $main::lxdebug->enter_sub();
2309 my ($self, $dbh, $default_key, $key) = @_;
2311 $key = $default_key unless ($key);
2312 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2314 $main::lxdebug->leave_sub();
2317 sub _get_business_types {
2318 $main::lxdebug->enter_sub();
2320 my ($self, $dbh, $key) = @_;
2322 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2323 $options->{key} ||= "all_business_types";
2326 if (exists $options->{salesman}) {
2327 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2330 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2332 $main::lxdebug->leave_sub();
2335 sub _get_languages {
2336 $main::lxdebug->enter_sub();
2338 my ($self, $dbh, $key) = @_;
2340 $key = "all_languages" unless ($key);
2342 my $query = qq|SELECT * FROM language ORDER BY id|;
2344 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2346 $main::lxdebug->leave_sub();
2349 sub _get_dunning_configs {
2350 $main::lxdebug->enter_sub();
2352 my ($self, $dbh, $key) = @_;
2354 $key = "all_dunning_configs" unless ($key);
2356 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2358 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2360 $main::lxdebug->leave_sub();
2363 sub _get_currencies {
2364 $main::lxdebug->enter_sub();
2366 my ($self, $dbh, $key) = @_;
2368 $key = "all_currencies" unless ($key);
2370 my $query = qq|SELECT curr AS currency FROM defaults|;
2372 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2374 $main::lxdebug->leave_sub();
2378 $main::lxdebug->enter_sub();
2380 my ($self, $dbh, $key) = @_;
2382 $key = "all_payments" unless ($key);
2384 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2386 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2388 $main::lxdebug->leave_sub();
2391 sub _get_customers {
2392 $main::lxdebug->enter_sub();
2394 my ($self, $dbh, $key) = @_;
2396 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2397 $options->{key} ||= "all_customers";
2398 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2401 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2402 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2403 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2405 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2406 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2408 $main::lxdebug->leave_sub();
2412 $main::lxdebug->enter_sub();
2414 my ($self, $dbh, $key) = @_;
2416 $key = "all_vendors" unless ($key);
2418 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2420 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2422 $main::lxdebug->leave_sub();
2425 sub _get_departments {
2426 $main::lxdebug->enter_sub();
2428 my ($self, $dbh, $key) = @_;
2430 $key = "all_departments" unless ($key);
2432 my $query = qq|SELECT * FROM department ORDER BY description|;
2434 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2436 $main::lxdebug->leave_sub();
2439 sub _get_warehouses {
2440 $main::lxdebug->enter_sub();
2442 my ($self, $dbh, $param) = @_;
2444 my ($key, $bins_key);
2446 if ('' eq ref $param) {
2450 $key = $param->{key};
2451 $bins_key = $param->{bins};
2454 my $query = qq|SELECT w.* FROM warehouse w
2455 WHERE (NOT w.invalid) AND
2456 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2457 ORDER BY w.sortkey|;
2459 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2462 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2463 my $sth = prepare_query($self, $dbh, $query);
2465 foreach my $warehouse (@{ $self->{$key} }) {
2466 do_statement($self, $sth, $query, $warehouse->{id});
2467 $warehouse->{$bins_key} = [];
2469 while (my $ref = $sth->fetchrow_hashref()) {
2470 push @{ $warehouse->{$bins_key} }, $ref;
2476 $main::lxdebug->leave_sub();
2480 $main::lxdebug->enter_sub();
2482 my ($self, $dbh, $table, $key, $sortkey) = @_;
2484 my $query = qq|SELECT * FROM $table|;
2485 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2487 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2489 $main::lxdebug->leave_sub();
2493 # $main::lxdebug->enter_sub();
2495 # my ($self, $dbh, $key) = @_;
2497 # $key ||= "all_groups";
2499 # my $groups = $main::auth->read_groups();
2501 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2503 # $main::lxdebug->leave_sub();
2507 $main::lxdebug->enter_sub();
2512 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2513 my ($sth, $query, $ref);
2515 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2516 my $vc_id = $self->{"${vc}_id"};
2518 if ($params{"contacts"}) {
2519 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2522 if ($params{"shipto"}) {
2523 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2526 if ($params{"projects"} || $params{"all_projects"}) {
2527 $self->_get_projects($dbh, $params{"all_projects"} ?
2528 $params{"all_projects"} : $params{"projects"},
2529 $params{"all_projects"} ? 1 : 0);
2532 if ($params{"printers"}) {
2533 $self->_get_printers($dbh, $params{"printers"});
2536 if ($params{"languages"}) {
2537 $self->_get_languages($dbh, $params{"languages"});
2540 if ($params{"charts"}) {
2541 $self->_get_charts($dbh, $params{"charts"});
2544 if ($params{"taxcharts"}) {
2545 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2548 if ($params{"taxzones"}) {
2549 $self->_get_taxzones($dbh, $params{"taxzones"});
2552 if ($params{"employees"}) {
2553 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2556 if ($params{"salesmen"}) {
2557 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2560 if ($params{"business_types"}) {
2561 $self->_get_business_types($dbh, $params{"business_types"});
2564 if ($params{"dunning_configs"}) {
2565 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2568 if($params{"currencies"}) {
2569 $self->_get_currencies($dbh, $params{"currencies"});
2572 if($params{"customers"}) {
2573 $self->_get_customers($dbh, $params{"customers"});
2576 if($params{"vendors"}) {
2577 if (ref $params{"vendors"} eq 'HASH') {
2578 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2580 $self->_get_vendors($dbh, $params{"vendors"});
2584 if($params{"payments"}) {
2585 $self->_get_payments($dbh, $params{"payments"});
2588 if($params{"departments"}) {
2589 $self->_get_departments($dbh, $params{"departments"});
2592 if ($params{price_factors}) {
2593 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2596 if ($params{warehouses}) {
2597 $self->_get_warehouses($dbh, $params{warehouses});
2600 # if ($params{groups}) {
2601 # $self->_get_groups($dbh, $params{groups});
2604 if ($params{partsgroup}) {
2605 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2608 $main::lxdebug->leave_sub();
2611 # this sub gets the id and name from $table
2613 $main::lxdebug->enter_sub();
2615 my ($self, $myconfig, $table) = @_;
2617 # connect to database
2618 my $dbh = $self->get_standard_dbh($myconfig);
2620 $table = $table eq "customer" ? "customer" : "vendor";
2621 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2623 my ($query, @values);
2625 if (!$self->{openinvoices}) {
2627 if ($self->{customernumber} ne "") {
2628 $where = qq|(vc.customernumber ILIKE ?)|;
2629 push(@values, '%' . $self->{customernumber} . '%');
2631 $where = qq|(vc.name ILIKE ?)|;
2632 push(@values, '%' . $self->{$table} . '%');
2636 qq~SELECT vc.id, vc.name,
2637 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2639 WHERE $where AND (NOT vc.obsolete)
2643 qq~SELECT DISTINCT vc.id, vc.name,
2644 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2646 JOIN $table vc ON (a.${table}_id = vc.id)
2647 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2649 push(@values, '%' . $self->{$table} . '%');
2652 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2654 $main::lxdebug->leave_sub();
2656 return scalar(@{ $self->{name_list} });
2659 # the selection sub is used in the AR, AP, IS, IR and OE module
2662 $main::lxdebug->enter_sub();
2664 my ($self, $myconfig, $table, $module) = @_;
2667 my $dbh = $self->get_standard_dbh;
2669 $table = $table eq "customer" ? "customer" : "vendor";
2671 my $query = qq|SELECT count(*) FROM $table|;
2672 my ($count) = selectrow_query($self, $dbh, $query);
2674 # build selection list
2675 if ($count <= $myconfig->{vclimit}) {
2676 $query = qq|SELECT id, name, salesman_id
2677 FROM $table WHERE NOT obsolete
2679 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2683 $self->get_employee($dbh);
2685 # setup sales contacts
2686 $query = qq|SELECT e.id, e.name
2688 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2689 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2692 push(@{ $self->{all_employees} },
2693 { id => $self->{employee_id},
2694 name => $self->{employee} });
2696 # sort the whole thing
2697 @{ $self->{all_employees} } =
2698 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2700 if ($module eq 'AR') {
2702 # prepare query for departments
2703 $query = qq|SELECT id, description
2706 ORDER BY description|;
2709 $query = qq|SELECT id, description
2711 ORDER BY description|;
2714 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2717 $query = qq|SELECT id, description
2721 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2724 $query = qq|SELECT printer_description, id
2726 ORDER BY printer_description|;
2728 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2731 $query = qq|SELECT id, description
2735 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2737 $main::lxdebug->leave_sub();
2740 sub language_payment {
2741 $main::lxdebug->enter_sub();
2743 my ($self, $myconfig) = @_;
2745 my $dbh = $self->get_standard_dbh($myconfig);
2747 my $query = qq|SELECT id, description
2751 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2754 $query = qq|SELECT printer_description, id
2756 ORDER BY printer_description|;
2758 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2761 $query = qq|SELECT id, description
2765 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2767 # get buchungsgruppen
2768 $query = qq|SELECT id, description
2769 FROM buchungsgruppen|;
2771 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2773 $main::lxdebug->leave_sub();
2776 # this is only used for reports
2777 sub all_departments {
2778 $main::lxdebug->enter_sub();
2780 my ($self, $myconfig, $table) = @_;
2782 my $dbh = $self->get_standard_dbh($myconfig);
2785 if ($table eq 'customer') {
2786 $where = "WHERE role = 'P' ";
2789 my $query = qq|SELECT id, description
2792 ORDER BY description|;
2793 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2795 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2797 $main::lxdebug->leave_sub();
2801 $main::lxdebug->enter_sub();
2803 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2806 if ($table eq "customer") {
2815 $self->all_vc($myconfig, $table, $module);
2817 # get last customers or vendors
2818 my ($query, $sth, $ref);
2820 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2825 my $transdate = "current_date";
2826 if ($self->{transdate}) {
2827 $transdate = $dbh->quote($self->{transdate});
2830 # now get the account numbers
2831 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2832 FROM chart c, taxkeys tk
2833 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2834 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2837 $sth = $dbh->prepare($query);
2839 do_statement($self, $sth, $query, '%' . $module . '%');
2841 $self->{accounts} = "";
2842 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2844 foreach my $key (split(/:/, $ref->{link})) {
2845 if ($key =~ /\Q$module\E/) {
2847 # cross reference for keys
2848 $xkeyref{ $ref->{accno} } = $key;
2850 push @{ $self->{"${module}_links"}{$key} },
2851 { accno => $ref->{accno},
2852 description => $ref->{description},
2853 taxkey => $ref->{taxkey_id},
2854 tax_id => $ref->{tax_id} };
2856 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2862 # get taxkeys and description
2863 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2864 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2866 if (($module eq "AP") || ($module eq "AR")) {
2867 # get tax rates and description
2868 $query = qq|SELECT * FROM tax|;
2869 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2875 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2876 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2877 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2878 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2880 d.description AS department,
2883 JOIN $table c ON (a.${table}_id = c.id)
2884 LEFT JOIN employee e ON (e.id = a.employee_id)
2885 LEFT JOIN department d ON (d.id = a.department_id)
2887 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2889 foreach my $key (keys %$ref) {
2890 $self->{$key} = $ref->{$key};
2893 my $transdate = "current_date";
2894 if ($self->{transdate}) {
2895 $transdate = $dbh->quote($self->{transdate});
2898 # now get the account numbers
2899 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2901 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2903 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2904 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2907 $sth = $dbh->prepare($query);
2908 do_statement($self, $sth, $query, "%$module%");
2910 $self->{accounts} = "";
2911 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2913 foreach my $key (split(/:/, $ref->{link})) {
2914 if ($key =~ /\Q$module\E/) {
2916 # cross reference for keys
2917 $xkeyref{ $ref->{accno} } = $key;
2919 push @{ $self->{"${module}_links"}{$key} },
2920 { accno => $ref->{accno},
2921 description => $ref->{description},
2922 taxkey => $ref->{taxkey_id},
2923 tax_id => $ref->{tax_id} };
2925 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2931 # get amounts from individual entries
2934 c.accno, c.description,
2935 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2939 LEFT JOIN chart c ON (c.id = a.chart_id)
2940 LEFT JOIN project p ON (p.id = a.project_id)
2941 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2942 WHERE (tk.taxkey_id=a.taxkey) AND
2943 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2944 THEN tk.chart_id = a.chart_id
2947 OR (c.link='%tax%')) AND
2948 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2949 WHERE a.trans_id = ?
2950 AND a.fx_transaction = '0'
2951 ORDER BY a.acc_trans_id, a.transdate|;
2952 $sth = $dbh->prepare($query);
2953 do_statement($self, $sth, $query, $self->{id});
2955 # get exchangerate for currency
2956 $self->{exchangerate} =
2957 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2960 # store amounts in {acc_trans}{$key} for multiple accounts
2961 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2962 $ref->{exchangerate} =
2963 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2964 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2967 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2968 $ref->{amount} *= -1;
2970 $ref->{index} = $index;
2972 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2978 d.curr AS currencies, d.closedto, d.revtrans,
2979 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2980 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2982 $ref = selectfirst_hashref_query($self, $dbh, $query);
2983 map { $self->{$_} = $ref->{$_} } keys %$ref;
2990 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2991 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2992 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2994 $ref = selectfirst_hashref_query($self, $dbh, $query);
2995 map { $self->{$_} = $ref->{$_} } keys %$ref;
2997 if ($self->{"$self->{vc}_id"}) {
2999 # only setup currency
3000 ($self->{currency}) = split(/:/, $self->{currencies});
3004 $self->lastname_used($dbh, $myconfig, $table, $module);
3006 # get exchangerate for currency
3007 $self->{exchangerate} =
3008 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3014 $main::lxdebug->leave_sub();
3018 $main::lxdebug->enter_sub();
3020 my ($self, $dbh, $myconfig, $table, $module) = @_;
3024 $table = $table eq "customer" ? "customer" : "vendor";
3025 my %column_map = ("a.curr" => "currency",
3026 "a.${table}_id" => "${table}_id",
3027 "a.department_id" => "department_id",
3028 "d.description" => "department",
3029 "ct.name" => $table,
3030 "current_date + ct.terms" => "duedate",
3033 if ($self->{type} =~ /delivery_order/) {
3034 $arap = 'delivery_orders';
3035 delete $column_map{"a.curr"};
3037 } elsif ($self->{type} =~ /_order/) {
3039 $where = "quotation = '0'";
3041 } elsif ($self->{type} =~ /_quotation/) {
3043 $where = "quotation = '1'";
3045 } elsif ($table eq 'customer') {
3053 $where = "($where) AND" if ($where);
3054 my $query = qq|SELECT MAX(id) FROM $arap
3055 WHERE $where ${table}_id > 0|;
3056 my ($trans_id) = selectrow_query($self, $dbh, $query);
3059 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3060 $query = qq|SELECT $column_spec
3062 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3063 LEFT JOIN department d ON (a.department_id = d.id)
3065 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3067 map { $self->{$_} = $ref->{$_} } values %column_map;
3069 $main::lxdebug->leave_sub();
3073 $main::lxdebug->enter_sub();
3076 my $myconfig = shift || \%::myconfig;
3077 my ($thisdate, $days) = @_;
3079 my $dbh = $self->get_standard_dbh($myconfig);
3084 my $dateformat = $myconfig->{dateformat};
3085 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3086 $thisdate = $dbh->quote($thisdate);
3087 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3089 $query = qq|SELECT current_date AS thisdate|;
3092 ($thisdate) = selectrow_query($self, $dbh, $query);
3094 $main::lxdebug->leave_sub();
3100 $main::lxdebug->enter_sub();
3102 my ($self, $string) = @_;
3104 if ($string !~ /%/) {
3105 $string = "%$string%";
3108 $string =~ s/\'/\'\'/g;
3110 $main::lxdebug->leave_sub();
3116 $main::lxdebug->enter_sub();
3118 my ($self, $flds, $new, $count, $numrows) = @_;
3122 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3127 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3129 my $j = $item->{ndx} - 1;
3130 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3134 for $i ($count + 1 .. $numrows) {
3135 map { delete $self->{"${_}_$i"} } @{$flds};
3138 $main::lxdebug->leave_sub();
3142 $main::lxdebug->enter_sub();
3144 my ($self, $myconfig) = @_;
3148 my $dbh = $self->dbconnect_noauto($myconfig);
3150 my $query = qq|DELETE FROM status
3151 WHERE (formname = ?) AND (trans_id = ?)|;
3152 my $sth = prepare_query($self, $dbh, $query);
3154 if ($self->{formname} =~ /(check|receipt)/) {
3155 for $i (1 .. $self->{rowcount}) {
3156 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3159 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3163 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3164 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3166 my %queued = split / /, $self->{queued};
3169 if ($self->{formname} =~ /(check|receipt)/) {
3171 # this is a check or receipt, add one entry for each lineitem
3172 my ($accno) = split /--/, $self->{account};
3173 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3174 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3175 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3176 $sth = prepare_query($self, $dbh, $query);
3178 for $i (1 .. $self->{rowcount}) {
3179 if ($self->{"checked_$i"}) {
3180 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3186 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3187 VALUES (?, ?, ?, ?, ?)|;
3188 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3189 $queued{$self->{formname}}, $self->{formname});
3195 $main::lxdebug->leave_sub();
3199 $main::lxdebug->enter_sub();
3201 my ($self, $dbh) = @_;
3203 my ($query, $printed, $emailed);
3205 my $formnames = $self->{printed};
3206 my $emailforms = $self->{emailed};
3208 $query = qq|DELETE FROM status
3209 WHERE (formname = ?) AND (trans_id = ?)|;
3210 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3212 # this only applies to the forms
3213 # checks and receipts are posted when printed or queued
3215 if ($self->{queued}) {
3216 my %queued = split / /, $self->{queued};
3218 foreach my $formname (keys %queued) {
3219 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3220 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3222 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3223 VALUES (?, ?, ?, ?, ?)|;
3224 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3226 $formnames =~ s/\Q$self->{formname}\E//;
3227 $emailforms =~ s/\Q$self->{formname}\E//;
3232 # save printed, emailed info
3233 $formnames =~ s/^ +//g;
3234 $emailforms =~ s/^ +//g;
3237 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3238 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3240 foreach my $formname (keys %status) {
3241 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3242 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3244 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3245 VALUES (?, ?, ?, ?)|;
3246 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3249 $main::lxdebug->leave_sub();
3253 # $main::locale->text('SAVED')
3254 # $main::locale->text('DELETED')
3255 # $main::locale->text('ADDED')
3256 # $main::locale->text('PAYMENT POSTED')
3257 # $main::locale->text('POSTED')
3258 # $main::locale->text('POSTED AS NEW')
3259 # $main::locale->text('ELSE')
3260 # $main::locale->text('SAVED FOR DUNNING')
3261 # $main::locale->text('DUNNING STARTED')
3262 # $main::locale->text('PRINTED')
3263 # $main::locale->text('MAILED')
3264 # $main::locale->text('SCREENED')
3265 # $main::locale->text('CANCELED')
3266 # $main::locale->text('invoice')
3267 # $main::locale->text('proforma')
3268 # $main::locale->text('sales_order')
3269 # $main::locale->text('pick_list')
3270 # $main::locale->text('purchase_order')
3271 # $main::locale->text('bin_list')
3272 # $main::locale->text('sales_quotation')
3273 # $main::locale->text('request_quotation')
3276 $main::lxdebug->enter_sub();
3279 my $dbh = shift || $self->get_standard_dbh;
3281 if(!exists $self->{employee_id}) {
3282 &get_employee($self, $dbh);
3286 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3287 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3288 my @values = (conv_i($self->{id}), $self->{login},
3289 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3290 do_query($self, $dbh, $query, @values);
3294 $main::lxdebug->leave_sub();
3298 $main::lxdebug->enter_sub();
3300 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3301 my ($orderBy, $desc) = split(/\-\-/, $order);
3302 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3305 if ($trans_id ne "") {
3307 qq|SELECT h.employee_id, h.itime::timestamp(0) AS itime, h.addition, h.what_done, emp.name, h.snumbers, h.trans_id AS id | .
3308 qq|FROM history_erp h | .
3309 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3310 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3313 my $sth = $dbh->prepare($query) || $self->dberror($query);
3315 $sth->execute() || $self->dberror("$query");
3317 while(my $hash_ref = $sth->fetchrow_hashref()) {
3318 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3319 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3320 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3321 $tempArray[$i++] = $hash_ref;
3323 $main::lxdebug->leave_sub() and return \@tempArray
3324 if ($i > 0 && $tempArray[0] ne "");
3326 $main::lxdebug->leave_sub();
3330 sub update_defaults {
3331 $main::lxdebug->enter_sub();
3333 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3336 if ($provided_dbh) {
3337 $dbh = $provided_dbh;
3339 $dbh = $self->dbconnect_noauto($myconfig);
3341 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3342 my $sth = $dbh->prepare($query);
3344 $sth->execute || $self->dberror($query);
3345 my ($var) = $sth->fetchrow_array;
3348 if ($var =~ m/\d+$/) {
3349 my $new_var = (substr $var, $-[0]) * 1 + 1;
3350 my $len_diff = length($var) - $-[0] - length($new_var);
3351 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3357 $query = qq|UPDATE defaults SET $fld = ?|;
3358 do_query($self, $dbh, $query, $var);
3360 if (!$provided_dbh) {
3365 $main::lxdebug->leave_sub();
3370 sub update_business {
3371 $main::lxdebug->enter_sub();
3373 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3376 if ($provided_dbh) {
3377 $dbh = $provided_dbh;
3379 $dbh = $self->dbconnect_noauto($myconfig);
3382 qq|SELECT customernumberinit FROM business
3383 WHERE id = ? FOR UPDATE|;
3384 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3386 return undef unless $var;
3388 if ($var =~ m/\d+$/) {
3389 my $new_var = (substr $var, $-[0]) * 1 + 1;
3390 my $len_diff = length($var) - $-[0] - length($new_var);
3391 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3397 $query = qq|UPDATE business
3398 SET customernumberinit = ?
3400 do_query($self, $dbh, $query, $var, $business_id);
3402 if (!$provided_dbh) {
3407 $main::lxdebug->leave_sub();
3412 sub get_partsgroup {
3413 $main::lxdebug->enter_sub();
3415 my ($self, $myconfig, $p) = @_;
3416 my $target = $p->{target} || 'all_partsgroup';
3418 my $dbh = $self->get_standard_dbh($myconfig);
3420 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3422 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3425 if ($p->{searchitems} eq 'part') {
3426 $query .= qq|WHERE p.inventory_accno_id > 0|;
3428 if ($p->{searchitems} eq 'service') {
3429 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3431 if ($p->{searchitems} eq 'assembly') {
3432 $query .= qq|WHERE p.assembly = '1'|;
3434 if ($p->{searchitems} eq 'labor') {
3435 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3438 $query .= qq|ORDER BY partsgroup|;
3441 $query = qq|SELECT id, partsgroup FROM partsgroup
3442 ORDER BY partsgroup|;
3445 if ($p->{language_code}) {
3446 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3447 t.description AS translation
3449 JOIN parts p ON (p.partsgroup_id = pg.id)
3450 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3451 ORDER BY translation|;
3452 @values = ($p->{language_code});
3455 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3457 $main::lxdebug->leave_sub();
3460 sub get_pricegroup {
3461 $main::lxdebug->enter_sub();
3463 my ($self, $myconfig, $p) = @_;
3465 my $dbh = $self->get_standard_dbh($myconfig);
3467 my $query = qq|SELECT p.id, p.pricegroup
3470 $query .= qq| ORDER BY pricegroup|;
3473 $query = qq|SELECT id, pricegroup FROM pricegroup
3474 ORDER BY pricegroup|;
3477 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3479 $main::lxdebug->leave_sub();
3483 # usage $form->all_years($myconfig, [$dbh])
3484 # return list of all years where bookings found
3487 $main::lxdebug->enter_sub();
3489 my ($self, $myconfig, $dbh) = @_;
3491 $dbh ||= $self->get_standard_dbh($myconfig);
3494 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3495 (SELECT MAX(transdate) FROM acc_trans)|;
3496 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3498 if ($myconfig->{dateformat} =~ /^yy/) {
3499 ($startdate) = split /\W/, $startdate;
3500 ($enddate) = split /\W/, $enddate;
3502 (@_) = split /\W/, $startdate;
3504 (@_) = split /\W/, $enddate;
3509 $startdate = substr($startdate,0,4);
3510 $enddate = substr($enddate,0,4);
3512 while ($enddate >= $startdate) {
3513 push @all_years, $enddate--;
3518 $main::lxdebug->leave_sub();
3522 $main::lxdebug->enter_sub();
3526 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3528 $main::lxdebug->leave_sub();
3532 $main::lxdebug->enter_sub();
3537 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3539 $main::lxdebug->leave_sub();
3542 sub prepare_for_printing {
3545 $self->{templates} ||= $::myconfig{templates};
3546 $self->{formname} ||= $self->{type};
3547 $self->{media} ||= 'email';
3549 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3551 # set shipto from billto unless set
3552 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3553 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3554 $self->{shiptoname} = $::myconfig{company};
3555 $self->{shiptostreet} = $::myconfig{address};
3558 my $language = $self->{language} ? '_' . $self->{language} : '';
3560 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3561 if ($self->{language_id}) {
3562 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3564 $output_dateformat = $::myconfig{dateformat};
3565 $output_numberformat = $::myconfig{numberformat};
3566 $output_longdates = 1;
3569 # Retrieve accounts for tax calculation.
3570 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3572 if ($self->{type} =~ /_delivery_order$/) {
3573 DO->order_details();
3574 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3575 OE->order_details(\%::myconfig, $self);
3577 IS->invoice_details(\%::myconfig, $self, $::locale);
3580 # Chose extension & set source file name
3581 my $extension = 'html';
3582 if ($self->{format} eq 'postscript') {
3583 $self->{postscript} = 1;
3585 } elsif ($self->{"format"} =~ /pdf/) {
3587 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3588 } elsif ($self->{"format"} =~ /opendocument/) {
3589 $self->{opendocument} = 1;
3591 } elsif ($self->{"format"} =~ /excel/) {
3596 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3597 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3598 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3601 $self->format_dates($output_dateformat, $output_longdates,
3602 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3603 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3604 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3606 $self->reformat_numbers($output_numberformat, 2,
3607 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3608 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3610 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3612 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3614 if (scalar @{ $cvar_date_fields }) {
3615 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3618 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3619 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3626 my ($self, $dateformat, $longformat, @indices) = @_;
3628 $dateformat ||= $::myconfig{dateformat};
3630 foreach my $idx (@indices) {
3631 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3632 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3633 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3637 next unless defined $self->{$idx};
3639 if (!ref($self->{$idx})) {
3640 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3642 } elsif (ref($self->{$idx}) eq "ARRAY") {
3643 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3644 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3650 sub reformat_numbers {
3651 my ($self, $numberformat, $places, @indices) = @_;
3653 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3655 foreach my $idx (@indices) {
3656 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3657 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3658 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3662 next unless defined $self->{$idx};
3664 if (!ref($self->{$idx})) {
3665 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3667 } elsif (ref($self->{$idx}) eq "ARRAY") {
3668 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3669 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3674 my $saved_numberformat = $::myconfig{numberformat};
3675 $::myconfig{numberformat} = $numberformat;
3677 foreach my $idx (@indices) {
3678 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3679 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3680 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3684 next unless defined $self->{$idx};
3686 if (!ref($self->{$idx})) {
3687 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3689 } elsif (ref($self->{$idx}) eq "ARRAY") {
3690 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3691 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3696 $::myconfig{numberformat} = $saved_numberformat;
3705 SL::Form.pm - main data object.
3709 This is the main data object of Lx-Office.
3710 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3711 Points of interest for a beginner are:
3713 - $form->error - renders a generic error in html. accepts an error message
3714 - $form->get_standard_dbh - returns a database connection for the
3716 =head1 SPECIAL FUNCTIONS
3718 =head2 C<_store_value()>
3720 parses a complex var name, and stores it in the form.
3723 $form->_store_value($key, $value);
3725 keys must start with a string, and can contain various tokens.
3726 supported key structures are:
3729 simple key strings work as expected
3734 separating two keys by a dot (.) will result in a hash lookup for the inner value
3735 this is similar to the behaviour of java and templating mechanisms.
3737 filter.description => $form->{filter}->{description}
3739 3. array+hashref access
3741 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3742 using [+] instead of [] will force a new array index. this is useful for recurring
3743 data structures like part lists. put a [+] into the first varname, and use [] on the
3746 repeating these names in your template:
3749 invoice.items[].parts_id
3753 $form->{invoice}->{items}->[
3767 using brackets at the end of a name will result in a pure array to be created.
3768 note that you mustn't use [+], which is reserved for array+hash access and will
3769 result in undefined behaviour in array context.
3771 filter.status[] => $form->{status}->[ val1, val2, ... ]
3773 =head2 C<update_business> PARAMS
3776 \%config, - config hashref
3777 $business_id, - business id
3778 $dbh - optional database handle
3780 handles business (thats customer/vendor types) sequences.
3782 special behaviour for empty strings in customerinitnumber field:
3783 will in this case not increase the value, and return undef.
3785 =head2 C<redirect_header> $url
3787 Generates a HTTP redirection header for the new C<$url>. Constructs an
3788 absolute URL including scheme, host name and port. If C<$url> is a
3789 relative URL then it is considered relative to Lx-Office base URL.
3791 This function C<die>s if headers have already been created with
3792 C<$::form-E<gt>header>.
3796 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3797 print $::form->redirect_header('http://www.lx-office.org/');
3801 Generates a general purpose http/html header and includes most of the scripts
3802 ans stylesheets needed.
3804 Only one header will be generated. If the method was already called in this
3805 request it will not output anything and return undef. Also if no
3806 HTTP_USER_AGENT is found, no header is generated.
3808 Although header does not accept parameters itself, it will honor special
3809 hashkeys of its Form instance:
3817 If one of these is set, a http-equiv refresh is generated. Missing parameters
3818 default to 3 seconds and the refering url.
3824 If these are arrayrefs the contents will be inlined into the header.
3828 If true, a css snippet will be generated that sets the page in landscape mode.
3832 Used to override the default favicon.
3836 A html page title will be generated from this