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 map { $cgi_params{'-' . $_} = $params{$_} if exists $params{$_} } qw(content_disposition content_length);
634 my $output = $cgi->header(%cgi_params);
636 $main::lxdebug->leave_sub();
643 $::lxdebug->enter_sub;
645 # extra code is currently only used by menuv3 and menuv4 to set their css.
646 # it is strongly deprecated, and will be changed in a future version.
647 my ($self, $extra_code) = @_;
648 my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
651 $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
653 $self->{favicon} ||= "favicon.ico";
654 $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title};
657 if ($self->{refresh_url} || $self->{refresh_time}) {
658 my $refresh_time = $self->{refresh_time} || 3;
659 my $refresh_url = $self->{refresh_url} || $ENV{REFERER};
660 push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
663 push @header, "<link rel='stylesheet' href='css/$_' type='text/css' title='Lx-Office stylesheet'>"
664 for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets};
666 push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
667 push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
668 push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
669 '<script type="text/javascript" src="js/common.js"></script>',
670 '<style type="text/css">@import url(js/jscalendar/calendar-win2k-1.css);</style>',
671 '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
672 '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
673 '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
674 '<script type="text/javascript" src="js/part_selection.js"></script>';
675 push @header, $self->{javascript} if $self->{javascript};
676 push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
677 push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
678 push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
679 join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title};
681 # if there is a title, we put some JavaScript in to the page, wich writes a
682 # meaningful title-tag for our frameset.
684 if ($self->{title}) {
686 <script type="text/javascript">
688 // Write a meaningful title-tag for our frameset.
689 top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
695 print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
696 print "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01//EN' 'http://www.w3.org/TR/html4/strict.dtd'>\n"
697 if $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/; # Other browsers may choke on menu scripts with DOCTYPE.
701 <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
702 <title>$self->{titlebar}</title>
704 print " $_\n" for @header;
706 <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css" />
707 <meta name="robots" content="noindex,nofollow" />
708 <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
709 <script type="text/javascript" src="js/tabcontent.js">
711 /***********************************************
712 * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
713 * This notice MUST stay intact for legal use
714 * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
715 ***********************************************/
724 $::lxdebug->leave_sub;
727 sub ajax_response_header {
728 $main::lxdebug->enter_sub();
732 my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
733 my $cgi = $main::cgi || CGI->new('');
734 my $output = $cgi->header('-charset' => $db_charset);
736 $main::lxdebug->leave_sub();
741 sub redirect_header {
745 my $base_uri = $self->_get_request_uri;
746 my $new_uri = URI->new_abs($new_url, $base_uri);
748 die "Headers already sent" if $::self->{header};
751 my $cgi = $main::cgi || CGI->new('');
752 return $cgi->redirect($new_uri);
755 sub set_standard_title {
756 $::lxdebug->enter_sub;
759 $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
760 $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
761 $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
763 $::lxdebug->leave_sub;
766 sub _prepare_html_template {
767 $main::lxdebug->enter_sub();
769 my ($self, $file, $additional_params) = @_;
772 if (!%::myconfig || !$::myconfig{"countrycode"}) {
773 $language = $::lx_office_conf{system}->{language};
775 $language = $main::myconfig{"countrycode"};
777 $language = "de" unless ($language);
779 if (-f "templates/webpages/${file}.html") {
780 if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
781 my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
782 "Please re-run 'locales.pl' in 'locale/${language}'.";
783 print(qq|<pre>$info</pre>|);
787 $file = "templates/webpages/${file}.html";
790 my $info = "Web page template '${file}' not found.\n";
791 print qq|<pre>$info</pre>|;
795 if ($self->{"DEBUG"}) {
796 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
799 if ($additional_params->{"DEBUG"}) {
800 $additional_params->{"DEBUG"} =
801 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
804 if (%main::myconfig) {
805 $::myconfig{jsc_dateformat} = apply {
809 } $::myconfig{"dateformat"};
810 $additional_params->{"myconfig"} ||= \%::myconfig;
811 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
814 $additional_params->{"conf_dbcharset"} = $::lx_office_conf{system}->{dbcharset};
815 $additional_params->{"conf_webdav"} = $::lx_office_conf{features}->{webdav};
816 $additional_params->{"conf_lizenzen"} = $::lx_office_conf{features}->{lizenzen};
817 $additional_params->{"conf_latex_templates"} = $::lx_office_conf{print_templates}->{latex};
818 $additional_params->{"conf_opendocument_templates"} = $::lx_office_conf{print_templates}->{opendocument};
819 $additional_params->{"conf_vertreter"} = $::lx_office_conf{features}->{vertreter};
820 $additional_params->{"conf_show_best_before"} = $::lx_office_conf{features}->{show_best_before};
821 $additional_params->{"conf_parts_image_css"} = $::lx_office_conf{features}->{parts_image_css};
822 $additional_params->{"conf_parts_listing_images"} = $::lx_office_conf{features}->{parts_listing_images};
823 $additional_params->{"conf_parts_show_image"} = $::lx_office_conf{features}->{parts_show_image};
825 if (%main::debug_options) {
826 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
829 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
830 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
831 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
835 $main::lxdebug->leave_sub();
840 sub parse_html_template {
841 $main::lxdebug->enter_sub();
843 my ($self, $file, $additional_params) = @_;
845 $additional_params ||= { };
847 my $real_file = $self->_prepare_html_template($file, $additional_params);
848 my $template = $self->template || $self->init_template;
850 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
853 $template->process($real_file, $additional_params, \$output) || die $template->error;
855 $main::lxdebug->leave_sub();
863 return if $self->template;
865 return $self->template(Template->new({
870 'PLUGIN_BASE' => 'SL::Template::Plugin',
871 'INCLUDE_PATH' => '.:templates/webpages',
872 'COMPILE_EXT' => '.tcc',
873 'COMPILE_DIR' => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
879 $self->{template_object} = shift if @_;
880 return $self->{template_object};
883 sub show_generic_error {
884 $main::lxdebug->enter_sub();
886 my ($self, $error, %params) = @_;
888 if ($self->{__ERROR_HANDLER}) {
889 $self->{__ERROR_HANDLER}->($error);
890 $main::lxdebug->leave_sub();
895 'title_error' => $params{title},
896 'label_error' => $error,
899 if ($params{action}) {
902 map { delete($self->{$_}); } qw(action);
903 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
905 $add_params->{SHOW_BUTTON} = 1;
906 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
907 $add_params->{VARIABLES} = \@vars;
909 } elsif ($params{back_button}) {
910 $add_params->{SHOW_BACK_BUTTON} = 1;
913 $self->{title} = $params{title} if $params{title};
916 print $self->parse_html_template("generic/error", $add_params);
918 print STDERR "Error: $error\n";
920 $main::lxdebug->leave_sub();
925 sub show_generic_information {
926 $main::lxdebug->enter_sub();
928 my ($self, $text, $title) = @_;
931 'title_information' => $title,
932 'label_information' => $text,
935 $self->{title} = $title if ($title);
938 print $self->parse_html_template("generic/information", $add_params);
940 $main::lxdebug->leave_sub();
945 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
946 # changed it to accept an arbitrary number of triggers - sschoeling
948 $main::lxdebug->enter_sub();
951 my $myconfig = shift;
954 # set dateform for jsscript
957 "dd.mm.yy" => "%d.%m.%Y",
958 "dd-mm-yy" => "%d-%m-%Y",
959 "dd/mm/yy" => "%d/%m/%Y",
960 "mm/dd/yy" => "%m/%d/%Y",
961 "mm-dd-yy" => "%m-%d-%Y",
962 "yyyy-mm-dd" => "%Y-%m-%d",
965 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
966 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
973 inputField : "| . (shift) . qq|",
974 ifFormat :"$ifFormat",
975 align : "| . (shift) . qq|",
976 button : "| . (shift) . qq|"
982 <script type="text/javascript">
983 <!--| . join("", @triggers) . qq|//-->
987 $main::lxdebug->leave_sub();
990 } #end sub write_trigger
993 $main::lxdebug->enter_sub();
995 my ($self, $msg) = @_;
997 if (!$self->{callback}) {
1003 # my ($script, $argv) = split(/\?/, $self->{callback}, 2);
1004 # $script =~ s|.*/||;
1005 # $script =~ s|[^a-zA-Z0-9_\.]||g;
1006 # exec("perl", "$script", $argv);
1008 print $::form->redirect_header($self->{callback});
1010 $main::lxdebug->leave_sub();
1013 # sort of columns removed - empty sub
1015 $main::lxdebug->enter_sub();
1017 my ($self, @columns) = @_;
1019 $main::lxdebug->leave_sub();
1025 $main::lxdebug->enter_sub(2);
1027 my ($self, $myconfig, $amount, $places, $dash) = @_;
1029 if ($amount eq "") {
1033 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1035 my $neg = ($amount =~ s/^-//);
1036 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1038 if (defined($places) && ($places ne '')) {
1044 my ($actual_places) = ($amount =~ /\.(\d+)/);
1045 $actual_places = length($actual_places);
1046 $places = $actual_places > $places ? $actual_places : $places;
1049 $amount = $self->round_amount($amount, $places);
1052 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1053 my @p = split(/\./, $amount); # split amount at decimal point
1055 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1058 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1061 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1062 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1063 ($neg ? "-$amount" : "$amount" ) ;
1067 $main::lxdebug->leave_sub(2);
1071 sub format_amount_units {
1072 $main::lxdebug->enter_sub();
1077 my $myconfig = \%main::myconfig;
1078 my $amount = $params{amount} * 1;
1079 my $places = $params{places};
1080 my $part_unit_name = $params{part_unit};
1081 my $amount_unit_name = $params{amount_unit};
1082 my $conv_units = $params{conv_units};
1083 my $max_places = $params{max_places};
1085 if (!$part_unit_name) {
1086 $main::lxdebug->leave_sub();
1090 AM->retrieve_all_units();
1091 my $all_units = $main::all_units;
1093 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1094 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1097 if (!scalar @{ $conv_units }) {
1098 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1099 $main::lxdebug->leave_sub();
1103 my $part_unit = $all_units->{$part_unit_name};
1104 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1106 $amount *= $conv_unit->{factor};
1111 foreach my $unit (@$conv_units) {
1112 my $last = $unit->{name} eq $part_unit->{name};
1114 $num = int($amount / $unit->{factor});
1115 $amount -= $num * $unit->{factor};
1118 if ($last ? $amount : $num) {
1119 push @values, { "unit" => $unit->{name},
1120 "amount" => $last ? $amount / $unit->{factor} : $num,
1121 "places" => $last ? $places : 0 };
1128 push @values, { "unit" => $part_unit_name,
1133 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1135 $main::lxdebug->leave_sub();
1141 $main::lxdebug->enter_sub(2);
1146 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1147 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1148 $input =~ s/\#\#/\#/g;
1150 $main::lxdebug->leave_sub(2);
1158 $main::lxdebug->enter_sub(2);
1160 my ($self, $myconfig, $amount) = @_;
1162 if ( ($myconfig->{numberformat} eq '1.000,00')
1163 || ($myconfig->{numberformat} eq '1000,00')) {
1168 if ($myconfig->{numberformat} eq "1'000.00") {
1174 $main::lxdebug->leave_sub(2);
1176 return ($amount * 1);
1180 $main::lxdebug->enter_sub(2);
1182 my ($self, $amount, $places) = @_;
1185 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1187 # Round amounts to eight places before rounding to the requested
1188 # number of places. This gets rid of errors due to internal floating
1189 # point representation.
1190 $amount = $self->round_amount($amount, 8) if $places < 8;
1191 $amount = $amount * (10**($places));
1192 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1194 $main::lxdebug->leave_sub(2);
1196 return $round_amount;
1200 sub parse_template {
1201 $main::lxdebug->enter_sub();
1203 my ($self, $myconfig) = @_;
1208 my $userspath = $::lx_office_conf{paths}->{userspath};
1210 $self->{"cwd"} = getcwd();
1211 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1216 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1217 $template_type = 'OpenDocument';
1218 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1220 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1221 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1222 $template_type = 'LaTeX';
1223 $ext_for_format = 'pdf';
1225 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1226 $template_type = 'HTML';
1227 $ext_for_format = 'html';
1229 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1230 $template_type = 'XML';
1231 $ext_for_format = 'xml';
1233 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1234 $template_type = 'XML';
1236 } elsif ( $self->{"format"} =~ /excel/i ) {
1237 $template_type = 'Excel';
1238 $ext_for_format = 'xls';
1240 } elsif ( defined $self->{'format'}) {
1241 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1243 } elsif ( $self->{'format'} eq '' ) {
1244 $self->error("No Outputformat given: $self->{'format'}");
1246 } else { #Catch the rest
1247 $self->error("Outputformat not defined: $self->{'format'}");
1250 my $template = SL::Template::create(type => $template_type,
1251 file_name => $self->{IN},
1253 myconfig => $myconfig,
1254 userspath => $userspath);
1256 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1257 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1259 if (!$self->{employee_id}) {
1260 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1263 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1264 map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1266 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1268 # OUT is used for the media, screen, printer, email
1269 # for postscript we store a copy in a temporary file
1271 my $prepend_userspath;
1273 if (!$self->{tmpfile}) {
1274 $self->{tmpfile} = "${fileid}.$self->{IN}";
1275 $prepend_userspath = 1;
1278 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1280 $self->{tmpfile} =~ s|.*/||;
1281 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1282 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1284 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1285 $out = $self->{OUT};
1286 $self->{OUT} = ">$self->{tmpfile}";
1292 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1293 $result = $template->parse(*OUT);
1298 $result = $template->parse(*STDOUT);
1303 $self->error("$self->{IN} : " . $template->get_error());
1306 if ($self->{media} eq 'file') {
1307 copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1309 chdir("$self->{cwd}");
1311 $::lxdebug->leave_sub();
1316 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1318 if ($self->{media} eq 'email') {
1320 my $mail = new Mailer;
1322 map { $mail->{$_} = $self->{$_} }
1323 qw(cc bcc subject message version format);
1324 $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1325 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1326 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1327 $mail->{fileid} = "$fileid.";
1328 $myconfig->{signature} =~ s/\r//g;
1330 # if we send html or plain text inline
1331 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1332 $mail->{contenttype} = "text/html";
1334 $mail->{message} =~ s/\r//g;
1335 $mail->{message} =~ s/\n/<br>\n/g;
1336 $myconfig->{signature} =~ s/\n/<br>\n/g;
1337 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1339 open(IN, $self->{tmpfile})
1340 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1342 $mail->{message} .= $_;
1349 if (!$self->{"do_not_attach"}) {
1350 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1351 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1352 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1353 "name" => $attachment_name }];
1356 $mail->{message} =~ s/\r//g;
1357 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1361 my $err = $mail->send();
1362 $self->error($self->cleanup . "$err") if ($err);
1366 $self->{OUT} = $out;
1368 my $numbytes = (-s $self->{tmpfile});
1369 open(IN, $self->{tmpfile})
1370 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1373 $self->{copies} = 1 unless $self->{media} eq 'printer';
1375 chdir("$self->{cwd}");
1376 #print(STDERR "Kopien $self->{copies}\n");
1377 #print(STDERR "OUT $self->{OUT}\n");
1378 for my $i (1 .. $self->{copies}) {
1380 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1381 print OUT while <IN>;
1386 $self->{attachment_filename} = ($self->{attachment_filename})
1387 ? $self->{attachment_filename}
1388 : $self->generate_attachment_filename();
1390 # launch application
1391 print qq|Content-Type: | . $template->get_mime_type() . qq|
1392 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1393 Content-Length: $numbytes
1397 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1408 chdir("$self->{cwd}");
1409 $main::lxdebug->leave_sub();
1412 sub get_formname_translation {
1413 $main::lxdebug->enter_sub();
1414 my ($self, $formname) = @_;
1416 $formname ||= $self->{formname};
1418 my %formname_translations = (
1419 bin_list => $main::locale->text('Bin List'),
1420 credit_note => $main::locale->text('Credit Note'),
1421 invoice => $main::locale->text('Invoice'),
1422 pick_list => $main::locale->text('Pick List'),
1423 proforma => $main::locale->text('Proforma Invoice'),
1424 purchase_order => $main::locale->text('Purchase Order'),
1425 request_quotation => $main::locale->text('RFQ'),
1426 sales_order => $main::locale->text('Confirmation'),
1427 sales_quotation => $main::locale->text('Quotation'),
1428 storno_invoice => $main::locale->text('Storno Invoice'),
1429 sales_delivery_order => $main::locale->text('Delivery Order'),
1430 purchase_delivery_order => $main::locale->text('Delivery Order'),
1431 dunning => $main::locale->text('Dunning'),
1434 $main::lxdebug->leave_sub();
1435 return $formname_translations{$formname}
1438 sub get_number_prefix_for_type {
1439 $main::lxdebug->enter_sub();
1443 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1444 : ($self->{type} =~ /_quotation$/) ? 'quo'
1445 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1448 $main::lxdebug->leave_sub();
1452 sub get_extension_for_format {
1453 $main::lxdebug->enter_sub();
1456 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1457 : $self->{format} =~ /postscript/i ? ".ps"
1458 : $self->{format} =~ /opendocument/i ? ".odt"
1459 : $self->{format} =~ /excel/i ? ".xls"
1460 : $self->{format} =~ /html/i ? ".html"
1463 $main::lxdebug->leave_sub();
1467 sub generate_attachment_filename {
1468 $main::lxdebug->enter_sub();
1471 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1472 my $prefix = $self->get_number_prefix_for_type();
1474 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1475 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1477 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1478 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1481 $attachment_filename = "";
1484 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1485 $attachment_filename =~ s|[\s/\\]+|_|g;
1487 $main::lxdebug->leave_sub();
1488 return $attachment_filename;
1491 sub generate_email_subject {
1492 $main::lxdebug->enter_sub();
1495 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1496 my $prefix = $self->get_number_prefix_for_type();
1498 if ($subject && $self->{"${prefix}number"}) {
1499 $subject .= " " . $self->{"${prefix}number"}
1502 $main::lxdebug->leave_sub();
1507 $main::lxdebug->enter_sub();
1511 chdir("$self->{tmpdir}");
1514 if (-f "$self->{tmpfile}.err") {
1515 open(FH, "$self->{tmpfile}.err");
1520 if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1521 $self->{tmpfile} =~ s|.*/||g;
1523 $self->{tmpfile} =~ s/\.\w+$//g;
1524 my $tmpfile = $self->{tmpfile};
1525 unlink(<$tmpfile.*>);
1528 chdir("$self->{cwd}");
1530 $main::lxdebug->leave_sub();
1536 $main::lxdebug->enter_sub();
1538 my ($self, $date, $myconfig) = @_;
1541 if ($date && $date =~ /\D/) {
1543 if ($myconfig->{dateformat} =~ /^yy/) {
1544 ($yy, $mm, $dd) = split /\D/, $date;
1546 if ($myconfig->{dateformat} =~ /^mm/) {
1547 ($mm, $dd, $yy) = split /\D/, $date;
1549 if ($myconfig->{dateformat} =~ /^dd/) {
1550 ($dd, $mm, $yy) = split /\D/, $date;
1555 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1556 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1558 $dd = "0$dd" if ($dd < 10);
1559 $mm = "0$mm" if ($mm < 10);
1561 $date = "$yy$mm$dd";
1564 $main::lxdebug->leave_sub();
1569 # Database routines used throughout
1571 sub _dbconnect_options {
1573 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1580 $main::lxdebug->enter_sub(2);
1582 my ($self, $myconfig) = @_;
1584 # connect to database
1585 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1589 if ($myconfig->{dboptions}) {
1590 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1593 $main::lxdebug->leave_sub(2);
1598 sub dbconnect_noauto {
1599 $main::lxdebug->enter_sub();
1601 my ($self, $myconfig) = @_;
1603 # connect to database
1604 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1608 if ($myconfig->{dboptions}) {
1609 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1612 $main::lxdebug->leave_sub();
1617 sub get_standard_dbh {
1618 $main::lxdebug->enter_sub(2);
1621 my $myconfig = shift || \%::myconfig;
1623 if ($standard_dbh && !$standard_dbh->{Active}) {
1624 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1625 undef $standard_dbh;
1628 $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1630 $main::lxdebug->leave_sub(2);
1632 return $standard_dbh;
1636 $main::lxdebug->enter_sub();
1638 my ($self, $date, $myconfig) = @_;
1639 my $dbh = $self->dbconnect($myconfig);
1641 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1642 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1643 my ($closed) = $sth->fetchrow_array;
1645 $main::lxdebug->leave_sub();
1650 sub update_balance {
1651 $main::lxdebug->enter_sub();
1653 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1655 # if we have a value, go do it
1658 # retrieve balance from table
1659 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1660 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1661 my ($balance) = $sth->fetchrow_array;
1667 $query = "UPDATE $table SET $field = $balance WHERE $where";
1668 do_query($self, $dbh, $query, @values);
1670 $main::lxdebug->leave_sub();
1673 sub update_exchangerate {
1674 $main::lxdebug->enter_sub();
1676 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1678 # some sanity check for currency
1680 $main::lxdebug->leave_sub();
1683 $query = qq|SELECT curr FROM defaults|;
1685 my ($currency) = selectrow_query($self, $dbh, $query);
1686 my ($defaultcurrency) = split m/:/, $currency;
1689 if ($curr eq $defaultcurrency) {
1690 $main::lxdebug->leave_sub();
1694 $query = qq|SELECT e.curr FROM exchangerate e
1695 WHERE e.curr = ? AND e.transdate = ?
1697 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1706 $buy = conv_i($buy, "NULL");
1707 $sell = conv_i($sell, "NULL");
1710 if ($buy != 0 && $sell != 0) {
1711 $set = "buy = $buy, sell = $sell";
1712 } elsif ($buy != 0) {
1713 $set = "buy = $buy";
1714 } elsif ($sell != 0) {
1715 $set = "sell = $sell";
1718 if ($sth->fetchrow_array) {
1719 $query = qq|UPDATE exchangerate
1725 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1726 VALUES (?, $buy, $sell, ?)|;
1729 do_query($self, $dbh, $query, $curr, $transdate);
1731 $main::lxdebug->leave_sub();
1734 sub save_exchangerate {
1735 $main::lxdebug->enter_sub();
1737 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1739 my $dbh = $self->dbconnect($myconfig);
1743 $buy = $rate if $fld eq 'buy';
1744 $sell = $rate if $fld eq 'sell';
1747 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1752 $main::lxdebug->leave_sub();
1755 sub get_exchangerate {
1756 $main::lxdebug->enter_sub();
1758 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1761 unless ($transdate) {
1762 $main::lxdebug->leave_sub();
1766 $query = qq|SELECT curr FROM defaults|;
1768 my ($currency) = selectrow_query($self, $dbh, $query);
1769 my ($defaultcurrency) = split m/:/, $currency;
1771 if ($currency eq $defaultcurrency) {
1772 $main::lxdebug->leave_sub();
1776 $query = qq|SELECT e.$fld FROM exchangerate e
1777 WHERE e.curr = ? AND e.transdate = ?|;
1778 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1782 $main::lxdebug->leave_sub();
1784 return $exchangerate;
1787 sub check_exchangerate {
1788 $main::lxdebug->enter_sub();
1790 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1792 if ($fld !~/^buy|sell$/) {
1793 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1796 unless ($transdate) {
1797 $main::lxdebug->leave_sub();
1801 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1803 if ($currency eq $defaultcurrency) {
1804 $main::lxdebug->leave_sub();
1808 my $dbh = $self->get_standard_dbh($myconfig);
1809 my $query = qq|SELECT e.$fld FROM exchangerate e
1810 WHERE e.curr = ? AND e.transdate = ?|;
1812 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1814 $main::lxdebug->leave_sub();
1816 return $exchangerate;
1819 sub get_all_currencies {
1820 $main::lxdebug->enter_sub();
1823 my $myconfig = shift || \%::myconfig;
1824 my $dbh = $self->get_standard_dbh($myconfig);
1826 my $query = qq|SELECT curr FROM defaults|;
1828 my ($curr) = selectrow_query($self, $dbh, $query);
1829 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1831 $main::lxdebug->leave_sub();
1836 sub get_default_currency {
1837 $main::lxdebug->enter_sub();
1839 my ($self, $myconfig) = @_;
1840 my @currencies = $self->get_all_currencies($myconfig);
1842 $main::lxdebug->leave_sub();
1844 return $currencies[0];
1847 sub set_payment_options {
1848 $main::lxdebug->enter_sub();
1850 my ($self, $myconfig, $transdate) = @_;
1852 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1854 my $dbh = $self->get_standard_dbh($myconfig);
1857 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1858 qq|FROM payment_terms p | .
1861 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1862 $self->{payment_terms}) =
1863 selectrow_query($self, $dbh, $query, $self->{payment_id});
1865 if ($transdate eq "") {
1866 if ($self->{invdate}) {
1867 $transdate = $self->{invdate};
1869 $transdate = $self->{transdate};
1874 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1875 qq|FROM payment_terms|;
1876 ($self->{netto_date}, $self->{skonto_date}) =
1877 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1879 my ($invtotal, $total);
1880 my (%amounts, %formatted_amounts);
1882 if ($self->{type} =~ /_order$/) {
1883 $amounts{invtotal} = $self->{ordtotal};
1884 $amounts{total} = $self->{ordtotal};
1886 } elsif ($self->{type} =~ /_quotation$/) {
1887 $amounts{invtotal} = $self->{quototal};
1888 $amounts{total} = $self->{quototal};
1891 $amounts{invtotal} = $self->{invtotal};
1892 $amounts{total} = $self->{total};
1894 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1896 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1898 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1899 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1900 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1902 foreach (keys %amounts) {
1903 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1904 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1907 if ($self->{"language_id"}) {
1909 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1910 qq|FROM translation_payment_terms t | .
1911 qq|LEFT JOIN language l ON t.language_id = l.id | .
1912 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1913 my ($description_long, $output_numberformat, $output_dateformat,
1914 $output_longdates) =
1915 selectrow_query($self, $dbh, $query,
1916 $self->{"language_id"}, $self->{"payment_id"});
1918 $self->{payment_terms} = $description_long if ($description_long);
1920 if ($output_dateformat) {
1921 foreach my $key (qw(netto_date skonto_date)) {
1923 $main::locale->reformat_date($myconfig, $self->{$key},
1929 if ($output_numberformat &&
1930 ($output_numberformat ne $myconfig->{"numberformat"})) {
1931 my $saved_numberformat = $myconfig->{"numberformat"};
1932 $myconfig->{"numberformat"} = $output_numberformat;
1933 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1934 $myconfig->{"numberformat"} = $saved_numberformat;
1938 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1939 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1940 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1941 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1942 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1943 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1944 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1946 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1948 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1950 $main::lxdebug->leave_sub();
1954 sub get_template_language {
1955 $main::lxdebug->enter_sub();
1957 my ($self, $myconfig) = @_;
1959 my $template_code = "";
1961 if ($self->{language_id}) {
1962 my $dbh = $self->get_standard_dbh($myconfig);
1963 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1964 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1967 $main::lxdebug->leave_sub();
1969 return $template_code;
1972 sub get_printer_code {
1973 $main::lxdebug->enter_sub();
1975 my ($self, $myconfig) = @_;
1977 my $template_code = "";
1979 if ($self->{printer_id}) {
1980 my $dbh = $self->get_standard_dbh($myconfig);
1981 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1982 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1985 $main::lxdebug->leave_sub();
1987 return $template_code;
1991 $main::lxdebug->enter_sub();
1993 my ($self, $myconfig) = @_;
1995 my $template_code = "";
1997 if ($self->{shipto_id}) {
1998 my $dbh = $self->get_standard_dbh($myconfig);
1999 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
2000 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
2001 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
2004 $main::lxdebug->leave_sub();
2008 $main::lxdebug->enter_sub();
2010 my ($self, $dbh, $id, $module) = @_;
2015 foreach my $item (qw(name department_1 department_2 street zipcode city country
2016 contact cp_gender phone fax email)) {
2017 if ($self->{"shipto$item"}) {
2018 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2020 push(@values, $self->{"shipto${item}"});
2024 if ($self->{shipto_id}) {
2025 my $query = qq|UPDATE shipto set
2027 shiptodepartment_1 = ?,
2028 shiptodepartment_2 = ?,
2034 shiptocp_gender = ?,
2038 WHERE shipto_id = ?|;
2039 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2041 my $query = qq|SELECT * FROM shipto
2042 WHERE shiptoname = ? AND
2043 shiptodepartment_1 = ? AND
2044 shiptodepartment_2 = ? AND
2045 shiptostreet = ? AND
2046 shiptozipcode = ? AND
2048 shiptocountry = ? AND
2049 shiptocontact = ? AND
2050 shiptocp_gender = ? AND
2056 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2059 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2060 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2061 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2062 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2063 do_query($self, $dbh, $query, $id, @values, $module);
2068 $main::lxdebug->leave_sub();
2072 $main::lxdebug->enter_sub();
2074 my ($self, $dbh) = @_;
2076 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2078 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2079 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2080 $self->{"employee_id"} *= 1;
2082 $main::lxdebug->leave_sub();
2085 sub get_employee_data {
2086 $main::lxdebug->enter_sub();
2091 Common::check_params(\%params, qw(prefix));
2092 Common::check_params_x(\%params, qw(id));
2095 $main::lxdebug->leave_sub();
2099 my $myconfig = \%main::myconfig;
2100 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2102 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2105 my $user = User->new($login);
2106 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2108 $self->{$params{prefix} . '_login'} = $login;
2109 $self->{$params{prefix} . '_name'} ||= $login;
2112 $main::lxdebug->leave_sub();
2116 $main::lxdebug->enter_sub();
2118 my ($self, $myconfig, $reference_date) = @_;
2120 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2122 my $dbh = $self->get_standard_dbh($myconfig);
2123 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2124 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2126 $main::lxdebug->leave_sub();
2132 $main::lxdebug->enter_sub();
2134 my ($self, $dbh, $id, $key) = @_;
2136 $key = "all_contacts" unless ($key);
2140 $main::lxdebug->leave_sub();
2145 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2146 qq|FROM contacts | .
2147 qq|WHERE cp_cv_id = ? | .
2148 qq|ORDER BY lower(cp_name)|;
2150 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2152 $main::lxdebug->leave_sub();
2156 $main::lxdebug->enter_sub();
2158 my ($self, $dbh, $key) = @_;
2160 my ($all, $old_id, $where, @values);
2162 if (ref($key) eq "HASH") {
2165 $key = "ALL_PROJECTS";
2167 foreach my $p (keys(%{$params})) {
2169 $all = $params->{$p};
2170 } elsif ($p eq "old_id") {
2171 $old_id = $params->{$p};
2172 } elsif ($p eq "key") {
2173 $key = $params->{$p};
2179 $where = "WHERE active ";
2181 if (ref($old_id) eq "ARRAY") {
2182 my @ids = grep({ $_ } @{$old_id});
2184 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2185 push(@values, @ids);
2188 $where .= " OR (id = ?) ";
2189 push(@values, $old_id);
2195 qq|SELECT id, projectnumber, description, active | .
2198 qq|ORDER BY lower(projectnumber)|;
2200 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2202 $main::lxdebug->leave_sub();
2206 $main::lxdebug->enter_sub();
2208 my ($self, $dbh, $vc_id, $key) = @_;
2210 $key = "all_shipto" unless ($key);
2213 # get shipping addresses
2214 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2216 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2222 $main::lxdebug->leave_sub();
2226 $main::lxdebug->enter_sub();
2228 my ($self, $dbh, $key) = @_;
2230 $key = "all_printers" unless ($key);
2232 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2234 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2236 $main::lxdebug->leave_sub();
2240 $main::lxdebug->enter_sub();
2242 my ($self, $dbh, $params) = @_;
2245 $key = $params->{key};
2246 $key = "all_charts" unless ($key);
2248 my $transdate = quote_db_date($params->{transdate});
2251 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2253 qq|LEFT JOIN taxkeys tk ON | .
2254 qq|(tk.id = (SELECT id FROM taxkeys | .
2255 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2256 qq| ORDER BY startdate DESC LIMIT 1)) | .
2257 qq|ORDER BY c.accno|;
2259 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2261 $main::lxdebug->leave_sub();
2264 sub _get_taxcharts {
2265 $main::lxdebug->enter_sub();
2267 my ($self, $dbh, $params) = @_;
2269 my $key = "all_taxcharts";
2272 if (ref $params eq 'HASH') {
2273 $key = $params->{key} if ($params->{key});
2274 if ($params->{module} eq 'AR') {
2275 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2277 } elsif ($params->{module} eq 'AP') {
2278 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2285 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2287 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2289 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2291 $main::lxdebug->leave_sub();
2295 $main::lxdebug->enter_sub();
2297 my ($self, $dbh, $key) = @_;
2299 $key = "all_taxzones" unless ($key);
2301 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2303 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2305 $main::lxdebug->leave_sub();
2308 sub _get_employees {
2309 $main::lxdebug->enter_sub();
2311 my ($self, $dbh, $default_key, $key) = @_;
2313 $key = $default_key unless ($key);
2314 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2316 $main::lxdebug->leave_sub();
2319 sub _get_business_types {
2320 $main::lxdebug->enter_sub();
2322 my ($self, $dbh, $key) = @_;
2324 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2325 $options->{key} ||= "all_business_types";
2328 if (exists $options->{salesman}) {
2329 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2332 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2334 $main::lxdebug->leave_sub();
2337 sub _get_languages {
2338 $main::lxdebug->enter_sub();
2340 my ($self, $dbh, $key) = @_;
2342 $key = "all_languages" unless ($key);
2344 my $query = qq|SELECT * FROM language ORDER BY id|;
2346 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2348 $main::lxdebug->leave_sub();
2351 sub _get_dunning_configs {
2352 $main::lxdebug->enter_sub();
2354 my ($self, $dbh, $key) = @_;
2356 $key = "all_dunning_configs" unless ($key);
2358 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2360 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2362 $main::lxdebug->leave_sub();
2365 sub _get_currencies {
2366 $main::lxdebug->enter_sub();
2368 my ($self, $dbh, $key) = @_;
2370 $key = "all_currencies" unless ($key);
2372 my $query = qq|SELECT curr AS currency FROM defaults|;
2374 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2376 $main::lxdebug->leave_sub();
2380 $main::lxdebug->enter_sub();
2382 my ($self, $dbh, $key) = @_;
2384 $key = "all_payments" unless ($key);
2386 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2388 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2390 $main::lxdebug->leave_sub();
2393 sub _get_customers {
2394 $main::lxdebug->enter_sub();
2396 my ($self, $dbh, $key) = @_;
2398 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2399 $options->{key} ||= "all_customers";
2400 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2403 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2404 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2405 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2407 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2408 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2410 $main::lxdebug->leave_sub();
2414 $main::lxdebug->enter_sub();
2416 my ($self, $dbh, $key) = @_;
2418 $key = "all_vendors" unless ($key);
2420 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2422 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2424 $main::lxdebug->leave_sub();
2427 sub _get_departments {
2428 $main::lxdebug->enter_sub();
2430 my ($self, $dbh, $key) = @_;
2432 $key = "all_departments" unless ($key);
2434 my $query = qq|SELECT * FROM department ORDER BY description|;
2436 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2438 $main::lxdebug->leave_sub();
2441 sub _get_warehouses {
2442 $main::lxdebug->enter_sub();
2444 my ($self, $dbh, $param) = @_;
2446 my ($key, $bins_key);
2448 if ('' eq ref $param) {
2452 $key = $param->{key};
2453 $bins_key = $param->{bins};
2456 my $query = qq|SELECT w.* FROM warehouse w
2457 WHERE (NOT w.invalid) AND
2458 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2459 ORDER BY w.sortkey|;
2461 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2464 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2465 my $sth = prepare_query($self, $dbh, $query);
2467 foreach my $warehouse (@{ $self->{$key} }) {
2468 do_statement($self, $sth, $query, $warehouse->{id});
2469 $warehouse->{$bins_key} = [];
2471 while (my $ref = $sth->fetchrow_hashref()) {
2472 push @{ $warehouse->{$bins_key} }, $ref;
2478 $main::lxdebug->leave_sub();
2482 $main::lxdebug->enter_sub();
2484 my ($self, $dbh, $table, $key, $sortkey) = @_;
2486 my $query = qq|SELECT * FROM $table|;
2487 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2489 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2491 $main::lxdebug->leave_sub();
2495 # $main::lxdebug->enter_sub();
2497 # my ($self, $dbh, $key) = @_;
2499 # $key ||= "all_groups";
2501 # my $groups = $main::auth->read_groups();
2503 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2505 # $main::lxdebug->leave_sub();
2509 $main::lxdebug->enter_sub();
2514 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2515 my ($sth, $query, $ref);
2517 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2518 my $vc_id = $self->{"${vc}_id"};
2520 if ($params{"contacts"}) {
2521 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2524 if ($params{"shipto"}) {
2525 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2528 if ($params{"projects"} || $params{"all_projects"}) {
2529 $self->_get_projects($dbh, $params{"all_projects"} ?
2530 $params{"all_projects"} : $params{"projects"},
2531 $params{"all_projects"} ? 1 : 0);
2534 if ($params{"printers"}) {
2535 $self->_get_printers($dbh, $params{"printers"});
2538 if ($params{"languages"}) {
2539 $self->_get_languages($dbh, $params{"languages"});
2542 if ($params{"charts"}) {
2543 $self->_get_charts($dbh, $params{"charts"});
2546 if ($params{"taxcharts"}) {
2547 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2550 if ($params{"taxzones"}) {
2551 $self->_get_taxzones($dbh, $params{"taxzones"});
2554 if ($params{"employees"}) {
2555 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2558 if ($params{"salesmen"}) {
2559 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2562 if ($params{"business_types"}) {
2563 $self->_get_business_types($dbh, $params{"business_types"});
2566 if ($params{"dunning_configs"}) {
2567 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2570 if($params{"currencies"}) {
2571 $self->_get_currencies($dbh, $params{"currencies"});
2574 if($params{"customers"}) {
2575 $self->_get_customers($dbh, $params{"customers"});
2578 if($params{"vendors"}) {
2579 if (ref $params{"vendors"} eq 'HASH') {
2580 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2582 $self->_get_vendors($dbh, $params{"vendors"});
2586 if($params{"payments"}) {
2587 $self->_get_payments($dbh, $params{"payments"});
2590 if($params{"departments"}) {
2591 $self->_get_departments($dbh, $params{"departments"});
2594 if ($params{price_factors}) {
2595 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2598 if ($params{warehouses}) {
2599 $self->_get_warehouses($dbh, $params{warehouses});
2602 # if ($params{groups}) {
2603 # $self->_get_groups($dbh, $params{groups});
2606 if ($params{partsgroup}) {
2607 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2610 $main::lxdebug->leave_sub();
2613 # this sub gets the id and name from $table
2615 $main::lxdebug->enter_sub();
2617 my ($self, $myconfig, $table) = @_;
2619 # connect to database
2620 my $dbh = $self->get_standard_dbh($myconfig);
2622 $table = $table eq "customer" ? "customer" : "vendor";
2623 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2625 my ($query, @values);
2627 if (!$self->{openinvoices}) {
2629 if ($self->{customernumber} ne "") {
2630 $where = qq|(vc.customernumber ILIKE ?)|;
2631 push(@values, '%' . $self->{customernumber} . '%');
2633 $where = qq|(vc.name ILIKE ?)|;
2634 push(@values, '%' . $self->{$table} . '%');
2638 qq~SELECT vc.id, vc.name,
2639 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2641 WHERE $where AND (NOT vc.obsolete)
2645 qq~SELECT DISTINCT vc.id, vc.name,
2646 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2648 JOIN $table vc ON (a.${table}_id = vc.id)
2649 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2651 push(@values, '%' . $self->{$table} . '%');
2654 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2656 $main::lxdebug->leave_sub();
2658 return scalar(@{ $self->{name_list} });
2661 # the selection sub is used in the AR, AP, IS, IR and OE module
2664 $main::lxdebug->enter_sub();
2666 my ($self, $myconfig, $table, $module) = @_;
2669 my $dbh = $self->get_standard_dbh;
2671 $table = $table eq "customer" ? "customer" : "vendor";
2673 my $query = qq|SELECT count(*) FROM $table|;
2674 my ($count) = selectrow_query($self, $dbh, $query);
2676 # build selection list
2677 if ($count <= $myconfig->{vclimit}) {
2678 $query = qq|SELECT id, name, salesman_id
2679 FROM $table WHERE NOT obsolete
2681 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2685 $self->get_employee($dbh);
2687 # setup sales contacts
2688 $query = qq|SELECT e.id, e.name
2690 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2691 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2694 push(@{ $self->{all_employees} },
2695 { id => $self->{employee_id},
2696 name => $self->{employee} });
2698 # sort the whole thing
2699 @{ $self->{all_employees} } =
2700 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2702 if ($module eq 'AR') {
2704 # prepare query for departments
2705 $query = qq|SELECT id, description
2708 ORDER BY description|;
2711 $query = qq|SELECT id, description
2713 ORDER BY description|;
2716 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2719 $query = qq|SELECT id, description
2723 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2726 $query = qq|SELECT printer_description, id
2728 ORDER BY printer_description|;
2730 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2733 $query = qq|SELECT id, description
2737 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2739 $main::lxdebug->leave_sub();
2742 sub language_payment {
2743 $main::lxdebug->enter_sub();
2745 my ($self, $myconfig) = @_;
2747 my $dbh = $self->get_standard_dbh($myconfig);
2749 my $query = qq|SELECT id, description
2753 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2756 $query = qq|SELECT printer_description, id
2758 ORDER BY printer_description|;
2760 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2763 $query = qq|SELECT id, description
2767 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2769 # get buchungsgruppen
2770 $query = qq|SELECT id, description
2771 FROM buchungsgruppen|;
2773 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2775 $main::lxdebug->leave_sub();
2778 # this is only used for reports
2779 sub all_departments {
2780 $main::lxdebug->enter_sub();
2782 my ($self, $myconfig, $table) = @_;
2784 my $dbh = $self->get_standard_dbh($myconfig);
2787 if ($table eq 'customer') {
2788 $where = "WHERE role = 'P' ";
2791 my $query = qq|SELECT id, description
2794 ORDER BY description|;
2795 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2797 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2799 $main::lxdebug->leave_sub();
2803 $main::lxdebug->enter_sub();
2805 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2808 if ($table eq "customer") {
2817 $self->all_vc($myconfig, $table, $module);
2819 # get last customers or vendors
2820 my ($query, $sth, $ref);
2822 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2827 my $transdate = "current_date";
2828 if ($self->{transdate}) {
2829 $transdate = $dbh->quote($self->{transdate});
2832 # now get the account numbers
2833 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2834 FROM chart c, taxkeys tk
2835 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2836 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2839 $sth = $dbh->prepare($query);
2841 do_statement($self, $sth, $query, '%' . $module . '%');
2843 $self->{accounts} = "";
2844 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2846 foreach my $key (split(/:/, $ref->{link})) {
2847 if ($key =~ /\Q$module\E/) {
2849 # cross reference for keys
2850 $xkeyref{ $ref->{accno} } = $key;
2852 push @{ $self->{"${module}_links"}{$key} },
2853 { accno => $ref->{accno},
2854 description => $ref->{description},
2855 taxkey => $ref->{taxkey_id},
2856 tax_id => $ref->{tax_id} };
2858 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2864 # get taxkeys and description
2865 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2866 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2868 if (($module eq "AP") || ($module eq "AR")) {
2869 # get tax rates and description
2870 $query = qq|SELECT * FROM tax|;
2871 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2877 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2878 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2879 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2880 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2882 d.description AS department,
2885 JOIN $table c ON (a.${table}_id = c.id)
2886 LEFT JOIN employee e ON (e.id = a.employee_id)
2887 LEFT JOIN department d ON (d.id = a.department_id)
2889 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2891 foreach my $key (keys %$ref) {
2892 $self->{$key} = $ref->{$key};
2895 my $transdate = "current_date";
2896 if ($self->{transdate}) {
2897 $transdate = $dbh->quote($self->{transdate});
2900 # now get the account numbers
2901 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2903 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2905 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2906 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2909 $sth = $dbh->prepare($query);
2910 do_statement($self, $sth, $query, "%$module%");
2912 $self->{accounts} = "";
2913 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2915 foreach my $key (split(/:/, $ref->{link})) {
2916 if ($key =~ /\Q$module\E/) {
2918 # cross reference for keys
2919 $xkeyref{ $ref->{accno} } = $key;
2921 push @{ $self->{"${module}_links"}{$key} },
2922 { accno => $ref->{accno},
2923 description => $ref->{description},
2924 taxkey => $ref->{taxkey_id},
2925 tax_id => $ref->{tax_id} };
2927 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2933 # get amounts from individual entries
2936 c.accno, c.description,
2937 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2941 LEFT JOIN chart c ON (c.id = a.chart_id)
2942 LEFT JOIN project p ON (p.id = a.project_id)
2943 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2944 WHERE (tk.taxkey_id=a.taxkey) AND
2945 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2946 THEN tk.chart_id = a.chart_id
2949 OR (c.link='%tax%')) AND
2950 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2951 WHERE a.trans_id = ?
2952 AND a.fx_transaction = '0'
2953 ORDER BY a.acc_trans_id, a.transdate|;
2954 $sth = $dbh->prepare($query);
2955 do_statement($self, $sth, $query, $self->{id});
2957 # get exchangerate for currency
2958 $self->{exchangerate} =
2959 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2962 # store amounts in {acc_trans}{$key} for multiple accounts
2963 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2964 $ref->{exchangerate} =
2965 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2966 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2969 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2970 $ref->{amount} *= -1;
2972 $ref->{index} = $index;
2974 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2980 d.curr AS currencies, d.closedto, d.revtrans,
2981 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2982 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2984 $ref = selectfirst_hashref_query($self, $dbh, $query);
2985 map { $self->{$_} = $ref->{$_} } keys %$ref;
2992 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2993 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2994 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2996 $ref = selectfirst_hashref_query($self, $dbh, $query);
2997 map { $self->{$_} = $ref->{$_} } keys %$ref;
2999 if ($self->{"$self->{vc}_id"}) {
3001 # only setup currency
3002 ($self->{currency}) = split(/:/, $self->{currencies});
3006 $self->lastname_used($dbh, $myconfig, $table, $module);
3008 # get exchangerate for currency
3009 $self->{exchangerate} =
3010 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3016 $main::lxdebug->leave_sub();
3020 $main::lxdebug->enter_sub();
3022 my ($self, $dbh, $myconfig, $table, $module) = @_;
3026 $table = $table eq "customer" ? "customer" : "vendor";
3027 my %column_map = ("a.curr" => "currency",
3028 "a.${table}_id" => "${table}_id",
3029 "a.department_id" => "department_id",
3030 "d.description" => "department",
3031 "ct.name" => $table,
3032 "current_date + ct.terms" => "duedate",
3035 if ($self->{type} =~ /delivery_order/) {
3036 $arap = 'delivery_orders';
3037 delete $column_map{"a.curr"};
3039 } elsif ($self->{type} =~ /_order/) {
3041 $where = "quotation = '0'";
3043 } elsif ($self->{type} =~ /_quotation/) {
3045 $where = "quotation = '1'";
3047 } elsif ($table eq 'customer') {
3055 $where = "($where) AND" if ($where);
3056 my $query = qq|SELECT MAX(id) FROM $arap
3057 WHERE $where ${table}_id > 0|;
3058 my ($trans_id) = selectrow_query($self, $dbh, $query);
3061 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3062 $query = qq|SELECT $column_spec
3064 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3065 LEFT JOIN department d ON (a.department_id = d.id)
3067 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3069 map { $self->{$_} = $ref->{$_} } values %column_map;
3071 $main::lxdebug->leave_sub();
3075 $main::lxdebug->enter_sub();
3078 my $myconfig = shift || \%::myconfig;
3079 my ($thisdate, $days) = @_;
3081 my $dbh = $self->get_standard_dbh($myconfig);
3086 my $dateformat = $myconfig->{dateformat};
3087 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3088 $thisdate = $dbh->quote($thisdate);
3089 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3091 $query = qq|SELECT current_date AS thisdate|;
3094 ($thisdate) = selectrow_query($self, $dbh, $query);
3096 $main::lxdebug->leave_sub();
3102 $main::lxdebug->enter_sub();
3104 my ($self, $string) = @_;
3106 if ($string !~ /%/) {
3107 $string = "%$string%";
3110 $string =~ s/\'/\'\'/g;
3112 $main::lxdebug->leave_sub();
3118 $main::lxdebug->enter_sub();
3120 my ($self, $flds, $new, $count, $numrows) = @_;
3124 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3129 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3131 my $j = $item->{ndx} - 1;
3132 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3136 for $i ($count + 1 .. $numrows) {
3137 map { delete $self->{"${_}_$i"} } @{$flds};
3140 $main::lxdebug->leave_sub();
3144 $main::lxdebug->enter_sub();
3146 my ($self, $myconfig) = @_;
3150 my $dbh = $self->dbconnect_noauto($myconfig);
3152 my $query = qq|DELETE FROM status
3153 WHERE (formname = ?) AND (trans_id = ?)|;
3154 my $sth = prepare_query($self, $dbh, $query);
3156 if ($self->{formname} =~ /(check|receipt)/) {
3157 for $i (1 .. $self->{rowcount}) {
3158 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3161 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3165 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3166 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3168 my %queued = split / /, $self->{queued};
3171 if ($self->{formname} =~ /(check|receipt)/) {
3173 # this is a check or receipt, add one entry for each lineitem
3174 my ($accno) = split /--/, $self->{account};
3175 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3176 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3177 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3178 $sth = prepare_query($self, $dbh, $query);
3180 for $i (1 .. $self->{rowcount}) {
3181 if ($self->{"checked_$i"}) {
3182 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3188 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3189 VALUES (?, ?, ?, ?, ?)|;
3190 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3191 $queued{$self->{formname}}, $self->{formname});
3197 $main::lxdebug->leave_sub();
3201 $main::lxdebug->enter_sub();
3203 my ($self, $dbh) = @_;
3205 my ($query, $printed, $emailed);
3207 my $formnames = $self->{printed};
3208 my $emailforms = $self->{emailed};
3210 $query = qq|DELETE FROM status
3211 WHERE (formname = ?) AND (trans_id = ?)|;
3212 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3214 # this only applies to the forms
3215 # checks and receipts are posted when printed or queued
3217 if ($self->{queued}) {
3218 my %queued = split / /, $self->{queued};
3220 foreach my $formname (keys %queued) {
3221 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3222 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3224 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3225 VALUES (?, ?, ?, ?, ?)|;
3226 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3228 $formnames =~ s/\Q$self->{formname}\E//;
3229 $emailforms =~ s/\Q$self->{formname}\E//;
3234 # save printed, emailed info
3235 $formnames =~ s/^ +//g;
3236 $emailforms =~ s/^ +//g;
3239 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3240 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3242 foreach my $formname (keys %status) {
3243 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3244 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3246 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3247 VALUES (?, ?, ?, ?)|;
3248 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3251 $main::lxdebug->leave_sub();
3255 # $main::locale->text('SAVED')
3256 # $main::locale->text('DELETED')
3257 # $main::locale->text('ADDED')
3258 # $main::locale->text('PAYMENT POSTED')
3259 # $main::locale->text('POSTED')
3260 # $main::locale->text('POSTED AS NEW')
3261 # $main::locale->text('ELSE')
3262 # $main::locale->text('SAVED FOR DUNNING')
3263 # $main::locale->text('DUNNING STARTED')
3264 # $main::locale->text('PRINTED')
3265 # $main::locale->text('MAILED')
3266 # $main::locale->text('SCREENED')
3267 # $main::locale->text('CANCELED')
3268 # $main::locale->text('invoice')
3269 # $main::locale->text('proforma')
3270 # $main::locale->text('sales_order')
3271 # $main::locale->text('pick_list')
3272 # $main::locale->text('purchase_order')
3273 # $main::locale->text('bin_list')
3274 # $main::locale->text('sales_quotation')
3275 # $main::locale->text('request_quotation')
3278 $main::lxdebug->enter_sub();
3281 my $dbh = shift || $self->get_standard_dbh;
3283 if(!exists $self->{employee_id}) {
3284 &get_employee($self, $dbh);
3288 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3289 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3290 my @values = (conv_i($self->{id}), $self->{login},
3291 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3292 do_query($self, $dbh, $query, @values);
3296 $main::lxdebug->leave_sub();
3300 $main::lxdebug->enter_sub();
3302 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3303 my ($orderBy, $desc) = split(/\-\-/, $order);
3304 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3307 if ($trans_id ne "") {
3309 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 | .
3310 qq|FROM history_erp h | .
3311 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3312 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3315 my $sth = $dbh->prepare($query) || $self->dberror($query);
3317 $sth->execute() || $self->dberror("$query");
3319 while(my $hash_ref = $sth->fetchrow_hashref()) {
3320 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3321 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3322 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3323 $tempArray[$i++] = $hash_ref;
3325 $main::lxdebug->leave_sub() and return \@tempArray
3326 if ($i > 0 && $tempArray[0] ne "");
3328 $main::lxdebug->leave_sub();
3332 sub update_defaults {
3333 $main::lxdebug->enter_sub();
3335 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3338 if ($provided_dbh) {
3339 $dbh = $provided_dbh;
3341 $dbh = $self->dbconnect_noauto($myconfig);
3343 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3344 my $sth = $dbh->prepare($query);
3346 $sth->execute || $self->dberror($query);
3347 my ($var) = $sth->fetchrow_array;
3350 if ($var =~ m/\d+$/) {
3351 my $new_var = (substr $var, $-[0]) * 1 + 1;
3352 my $len_diff = length($var) - $-[0] - length($new_var);
3353 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3359 $query = qq|UPDATE defaults SET $fld = ?|;
3360 do_query($self, $dbh, $query, $var);
3362 if (!$provided_dbh) {
3367 $main::lxdebug->leave_sub();
3372 sub update_business {
3373 $main::lxdebug->enter_sub();
3375 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3378 if ($provided_dbh) {
3379 $dbh = $provided_dbh;
3381 $dbh = $self->dbconnect_noauto($myconfig);
3384 qq|SELECT customernumberinit FROM business
3385 WHERE id = ? FOR UPDATE|;
3386 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3388 return undef unless $var;
3390 if ($var =~ m/\d+$/) {
3391 my $new_var = (substr $var, $-[0]) * 1 + 1;
3392 my $len_diff = length($var) - $-[0] - length($new_var);
3393 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3399 $query = qq|UPDATE business
3400 SET customernumberinit = ?
3402 do_query($self, $dbh, $query, $var, $business_id);
3404 if (!$provided_dbh) {
3409 $main::lxdebug->leave_sub();
3414 sub get_partsgroup {
3415 $main::lxdebug->enter_sub();
3417 my ($self, $myconfig, $p) = @_;
3418 my $target = $p->{target} || 'all_partsgroup';
3420 my $dbh = $self->get_standard_dbh($myconfig);
3422 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3424 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3427 if ($p->{searchitems} eq 'part') {
3428 $query .= qq|WHERE p.inventory_accno_id > 0|;
3430 if ($p->{searchitems} eq 'service') {
3431 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3433 if ($p->{searchitems} eq 'assembly') {
3434 $query .= qq|WHERE p.assembly = '1'|;
3436 if ($p->{searchitems} eq 'labor') {
3437 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3440 $query .= qq|ORDER BY partsgroup|;
3443 $query = qq|SELECT id, partsgroup FROM partsgroup
3444 ORDER BY partsgroup|;
3447 if ($p->{language_code}) {
3448 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3449 t.description AS translation
3451 JOIN parts p ON (p.partsgroup_id = pg.id)
3452 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3453 ORDER BY translation|;
3454 @values = ($p->{language_code});
3457 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3459 $main::lxdebug->leave_sub();
3462 sub get_pricegroup {
3463 $main::lxdebug->enter_sub();
3465 my ($self, $myconfig, $p) = @_;
3467 my $dbh = $self->get_standard_dbh($myconfig);
3469 my $query = qq|SELECT p.id, p.pricegroup
3472 $query .= qq| ORDER BY pricegroup|;
3475 $query = qq|SELECT id, pricegroup FROM pricegroup
3476 ORDER BY pricegroup|;
3479 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3481 $main::lxdebug->leave_sub();
3485 # usage $form->all_years($myconfig, [$dbh])
3486 # return list of all years where bookings found
3489 $main::lxdebug->enter_sub();
3491 my ($self, $myconfig, $dbh) = @_;
3493 $dbh ||= $self->get_standard_dbh($myconfig);
3496 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3497 (SELECT MAX(transdate) FROM acc_trans)|;
3498 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3500 if ($myconfig->{dateformat} =~ /^yy/) {
3501 ($startdate) = split /\W/, $startdate;
3502 ($enddate) = split /\W/, $enddate;
3504 (@_) = split /\W/, $startdate;
3506 (@_) = split /\W/, $enddate;
3511 $startdate = substr($startdate,0,4);
3512 $enddate = substr($enddate,0,4);
3514 while ($enddate >= $startdate) {
3515 push @all_years, $enddate--;
3520 $main::lxdebug->leave_sub();
3524 $main::lxdebug->enter_sub();
3528 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3530 $main::lxdebug->leave_sub();
3534 $main::lxdebug->enter_sub();
3539 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3541 $main::lxdebug->leave_sub();
3544 sub prepare_for_printing {
3547 $self->{templates} ||= $::myconfig{templates};
3548 $self->{formname} ||= $self->{type};
3549 $self->{media} ||= 'email';
3551 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3553 # set shipto from billto unless set
3554 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3555 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3556 $self->{shiptoname} = $::myconfig{company};
3557 $self->{shiptostreet} = $::myconfig{address};
3560 my $language = $self->{language} ? '_' . $self->{language} : '';
3562 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3563 if ($self->{language_id}) {
3564 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3566 $output_dateformat = $::myconfig{dateformat};
3567 $output_numberformat = $::myconfig{numberformat};
3568 $output_longdates = 1;
3571 # Retrieve accounts for tax calculation.
3572 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3574 if ($self->{type} =~ /_delivery_order$/) {
3575 DO->order_details();
3576 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3577 OE->order_details(\%::myconfig, $self);
3579 IS->invoice_details(\%::myconfig, $self, $::locale);
3582 # Chose extension & set source file name
3583 my $extension = 'html';
3584 if ($self->{format} eq 'postscript') {
3585 $self->{postscript} = 1;
3587 } elsif ($self->{"format"} =~ /pdf/) {
3589 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3590 } elsif ($self->{"format"} =~ /opendocument/) {
3591 $self->{opendocument} = 1;
3593 } elsif ($self->{"format"} =~ /excel/) {
3598 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3599 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3600 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3603 $self->format_dates($output_dateformat, $output_longdates,
3604 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3605 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3606 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3608 $self->reformat_numbers($output_numberformat, 2,
3609 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3610 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3612 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3614 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3616 if (scalar @{ $cvar_date_fields }) {
3617 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3620 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3621 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3628 my ($self, $dateformat, $longformat, @indices) = @_;
3630 $dateformat ||= $::myconfig{dateformat};
3632 foreach my $idx (@indices) {
3633 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3634 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3635 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3639 next unless defined $self->{$idx};
3641 if (!ref($self->{$idx})) {
3642 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3644 } elsif (ref($self->{$idx}) eq "ARRAY") {
3645 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3646 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3652 sub reformat_numbers {
3653 my ($self, $numberformat, $places, @indices) = @_;
3655 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3657 foreach my $idx (@indices) {
3658 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3659 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3660 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3664 next unless defined $self->{$idx};
3666 if (!ref($self->{$idx})) {
3667 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3669 } elsif (ref($self->{$idx}) eq "ARRAY") {
3670 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3671 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3676 my $saved_numberformat = $::myconfig{numberformat};
3677 $::myconfig{numberformat} = $numberformat;
3679 foreach my $idx (@indices) {
3680 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3681 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3682 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3686 next unless defined $self->{$idx};
3688 if (!ref($self->{$idx})) {
3689 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3691 } elsif (ref($self->{$idx}) eq "ARRAY") {
3692 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3693 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3698 $::myconfig{numberformat} = $saved_numberformat;
3707 SL::Form.pm - main data object.
3711 This is the main data object of Lx-Office.
3712 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3713 Points of interest for a beginner are:
3715 - $form->error - renders a generic error in html. accepts an error message
3716 - $form->get_standard_dbh - returns a database connection for the
3718 =head1 SPECIAL FUNCTIONS
3720 =head2 C<_store_value()>
3722 parses a complex var name, and stores it in the form.
3725 $form->_store_value($key, $value);
3727 keys must start with a string, and can contain various tokens.
3728 supported key structures are:
3731 simple key strings work as expected
3736 separating two keys by a dot (.) will result in a hash lookup for the inner value
3737 this is similar to the behaviour of java and templating mechanisms.
3739 filter.description => $form->{filter}->{description}
3741 3. array+hashref access
3743 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3744 using [+] instead of [] will force a new array index. this is useful for recurring
3745 data structures like part lists. put a [+] into the first varname, and use [] on the
3748 repeating these names in your template:
3751 invoice.items[].parts_id
3755 $form->{invoice}->{items}->[
3769 using brackets at the end of a name will result in a pure array to be created.
3770 note that you mustn't use [+], which is reserved for array+hash access and will
3771 result in undefined behaviour in array context.
3773 filter.status[] => $form->{status}->[ val1, val2, ... ]
3775 =head2 C<update_business> PARAMS
3778 \%config, - config hashref
3779 $business_id, - business id
3780 $dbh - optional database handle
3782 handles business (thats customer/vendor types) sequences.
3784 special behaviour for empty strings in customerinitnumber field:
3785 will in this case not increase the value, and return undef.
3787 =head2 C<redirect_header> $url
3789 Generates a HTTP redirection header for the new C<$url>. Constructs an
3790 absolute URL including scheme, host name and port. If C<$url> is a
3791 relative URL then it is considered relative to Lx-Office base URL.
3793 This function C<die>s if headers have already been created with
3794 C<$::form-E<gt>header>.
3798 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3799 print $::form->redirect_header('http://www.lx-office.org/');
3803 Generates a general purpose http/html header and includes most of the scripts
3804 ans stylesheets needed.
3806 Only one header will be generated. If the method was already called in this
3807 request it will not output anything and return undef. Also if no
3808 HTTP_USER_AGENT is found, no header is generated.
3810 Although header does not accept parameters itself, it will honor special
3811 hashkeys of its Form instance:
3819 If one of these is set, a http-equiv refresh is generated. Missing parameters
3820 default to 3 seconds and the refering url.
3826 If these are arrayrefs the contents will be inlined into the header.
3830 If true, a css snippet will be generated that sets the page in landscape mode.
3834 Used to override the default favicon.
3838 A html page title will be generated from this