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 ORDER BY description|;
2466 my $sth = prepare_query($self, $dbh, $query);
2468 foreach my $warehouse (@{ $self->{$key} }) {
2469 do_statement($self, $sth, $query, $warehouse->{id});
2470 $warehouse->{$bins_key} = [];
2472 while (my $ref = $sth->fetchrow_hashref()) {
2473 push @{ $warehouse->{$bins_key} }, $ref;
2479 $main::lxdebug->leave_sub();
2483 $main::lxdebug->enter_sub();
2485 my ($self, $dbh, $table, $key, $sortkey) = @_;
2487 my $query = qq|SELECT * FROM $table|;
2488 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2490 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2492 $main::lxdebug->leave_sub();
2496 # $main::lxdebug->enter_sub();
2498 # my ($self, $dbh, $key) = @_;
2500 # $key ||= "all_groups";
2502 # my $groups = $main::auth->read_groups();
2504 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2506 # $main::lxdebug->leave_sub();
2510 $main::lxdebug->enter_sub();
2515 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2516 my ($sth, $query, $ref);
2518 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2519 my $vc_id = $self->{"${vc}_id"};
2521 if ($params{"contacts"}) {
2522 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2525 if ($params{"shipto"}) {
2526 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2529 if ($params{"projects"} || $params{"all_projects"}) {
2530 $self->_get_projects($dbh, $params{"all_projects"} ?
2531 $params{"all_projects"} : $params{"projects"},
2532 $params{"all_projects"} ? 1 : 0);
2535 if ($params{"printers"}) {
2536 $self->_get_printers($dbh, $params{"printers"});
2539 if ($params{"languages"}) {
2540 $self->_get_languages($dbh, $params{"languages"});
2543 if ($params{"charts"}) {
2544 $self->_get_charts($dbh, $params{"charts"});
2547 if ($params{"taxcharts"}) {
2548 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2551 if ($params{"taxzones"}) {
2552 $self->_get_taxzones($dbh, $params{"taxzones"});
2555 if ($params{"employees"}) {
2556 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2559 if ($params{"salesmen"}) {
2560 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2563 if ($params{"business_types"}) {
2564 $self->_get_business_types($dbh, $params{"business_types"});
2567 if ($params{"dunning_configs"}) {
2568 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2571 if($params{"currencies"}) {
2572 $self->_get_currencies($dbh, $params{"currencies"});
2575 if($params{"customers"}) {
2576 $self->_get_customers($dbh, $params{"customers"});
2579 if($params{"vendors"}) {
2580 if (ref $params{"vendors"} eq 'HASH') {
2581 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2583 $self->_get_vendors($dbh, $params{"vendors"});
2587 if($params{"payments"}) {
2588 $self->_get_payments($dbh, $params{"payments"});
2591 if($params{"departments"}) {
2592 $self->_get_departments($dbh, $params{"departments"});
2595 if ($params{price_factors}) {
2596 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2599 if ($params{warehouses}) {
2600 $self->_get_warehouses($dbh, $params{warehouses});
2603 # if ($params{groups}) {
2604 # $self->_get_groups($dbh, $params{groups});
2607 if ($params{partsgroup}) {
2608 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2611 $main::lxdebug->leave_sub();
2614 # this sub gets the id and name from $table
2616 $main::lxdebug->enter_sub();
2618 my ($self, $myconfig, $table) = @_;
2620 # connect to database
2621 my $dbh = $self->get_standard_dbh($myconfig);
2623 $table = $table eq "customer" ? "customer" : "vendor";
2624 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2626 my ($query, @values);
2628 if (!$self->{openinvoices}) {
2630 if ($self->{customernumber} ne "") {
2631 $where = qq|(vc.customernumber ILIKE ?)|;
2632 push(@values, '%' . $self->{customernumber} . '%');
2634 $where = qq|(vc.name ILIKE ?)|;
2635 push(@values, '%' . $self->{$table} . '%');
2639 qq~SELECT vc.id, vc.name,
2640 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2642 WHERE $where AND (NOT vc.obsolete)
2646 qq~SELECT DISTINCT vc.id, vc.name,
2647 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2649 JOIN $table vc ON (a.${table}_id = vc.id)
2650 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2652 push(@values, '%' . $self->{$table} . '%');
2655 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2657 $main::lxdebug->leave_sub();
2659 return scalar(@{ $self->{name_list} });
2662 # the selection sub is used in the AR, AP, IS, IR and OE module
2665 $main::lxdebug->enter_sub();
2667 my ($self, $myconfig, $table, $module) = @_;
2670 my $dbh = $self->get_standard_dbh;
2672 $table = $table eq "customer" ? "customer" : "vendor";
2674 my $query = qq|SELECT count(*) FROM $table|;
2675 my ($count) = selectrow_query($self, $dbh, $query);
2677 # build selection list
2678 if ($count <= $myconfig->{vclimit}) {
2679 $query = qq|SELECT id, name, salesman_id
2680 FROM $table WHERE NOT obsolete
2682 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2686 $self->get_employee($dbh);
2688 # setup sales contacts
2689 $query = qq|SELECT e.id, e.name
2691 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2692 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2695 push(@{ $self->{all_employees} },
2696 { id => $self->{employee_id},
2697 name => $self->{employee} });
2699 # sort the whole thing
2700 @{ $self->{all_employees} } =
2701 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2703 if ($module eq 'AR') {
2705 # prepare query for departments
2706 $query = qq|SELECT id, description
2709 ORDER BY description|;
2712 $query = qq|SELECT id, description
2714 ORDER BY description|;
2717 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2720 $query = qq|SELECT id, description
2724 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2727 $query = qq|SELECT printer_description, id
2729 ORDER BY printer_description|;
2731 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2734 $query = qq|SELECT id, description
2738 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2740 $main::lxdebug->leave_sub();
2743 sub language_payment {
2744 $main::lxdebug->enter_sub();
2746 my ($self, $myconfig) = @_;
2748 my $dbh = $self->get_standard_dbh($myconfig);
2750 my $query = qq|SELECT id, description
2754 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2757 $query = qq|SELECT printer_description, id
2759 ORDER BY printer_description|;
2761 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2764 $query = qq|SELECT id, description
2768 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2770 # get buchungsgruppen
2771 $query = qq|SELECT id, description
2772 FROM buchungsgruppen|;
2774 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2776 $main::lxdebug->leave_sub();
2779 # this is only used for reports
2780 sub all_departments {
2781 $main::lxdebug->enter_sub();
2783 my ($self, $myconfig, $table) = @_;
2785 my $dbh = $self->get_standard_dbh($myconfig);
2788 if ($table eq 'customer') {
2789 $where = "WHERE role = 'P' ";
2792 my $query = qq|SELECT id, description
2795 ORDER BY description|;
2796 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2798 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2800 $main::lxdebug->leave_sub();
2804 $main::lxdebug->enter_sub();
2806 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2809 if ($table eq "customer") {
2818 $self->all_vc($myconfig, $table, $module);
2820 # get last customers or vendors
2821 my ($query, $sth, $ref);
2823 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2828 my $transdate = "current_date";
2829 if ($self->{transdate}) {
2830 $transdate = $dbh->quote($self->{transdate});
2833 # now get the account numbers
2834 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2835 FROM chart c, taxkeys tk
2836 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2837 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2840 $sth = $dbh->prepare($query);
2842 do_statement($self, $sth, $query, '%' . $module . '%');
2844 $self->{accounts} = "";
2845 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2847 foreach my $key (split(/:/, $ref->{link})) {
2848 if ($key =~ /\Q$module\E/) {
2850 # cross reference for keys
2851 $xkeyref{ $ref->{accno} } = $key;
2853 push @{ $self->{"${module}_links"}{$key} },
2854 { accno => $ref->{accno},
2855 description => $ref->{description},
2856 taxkey => $ref->{taxkey_id},
2857 tax_id => $ref->{tax_id} };
2859 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2865 # get taxkeys and description
2866 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2867 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2869 if (($module eq "AP") || ($module eq "AR")) {
2870 # get tax rates and description
2871 $query = qq|SELECT * FROM tax|;
2872 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2878 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2879 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2880 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2881 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2883 d.description AS department,
2886 JOIN $table c ON (a.${table}_id = c.id)
2887 LEFT JOIN employee e ON (e.id = a.employee_id)
2888 LEFT JOIN department d ON (d.id = a.department_id)
2890 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2892 foreach my $key (keys %$ref) {
2893 $self->{$key} = $ref->{$key};
2896 my $transdate = "current_date";
2897 if ($self->{transdate}) {
2898 $transdate = $dbh->quote($self->{transdate});
2901 # now get the account numbers
2902 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2904 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2906 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2907 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2910 $sth = $dbh->prepare($query);
2911 do_statement($self, $sth, $query, "%$module%");
2913 $self->{accounts} = "";
2914 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2916 foreach my $key (split(/:/, $ref->{link})) {
2917 if ($key =~ /\Q$module\E/) {
2919 # cross reference for keys
2920 $xkeyref{ $ref->{accno} } = $key;
2922 push @{ $self->{"${module}_links"}{$key} },
2923 { accno => $ref->{accno},
2924 description => $ref->{description},
2925 taxkey => $ref->{taxkey_id},
2926 tax_id => $ref->{tax_id} };
2928 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2934 # get amounts from individual entries
2937 c.accno, c.description,
2938 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2942 LEFT JOIN chart c ON (c.id = a.chart_id)
2943 LEFT JOIN project p ON (p.id = a.project_id)
2944 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2945 WHERE (tk.taxkey_id=a.taxkey) AND
2946 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2947 THEN tk.chart_id = a.chart_id
2950 OR (c.link='%tax%')) AND
2951 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2952 WHERE a.trans_id = ?
2953 AND a.fx_transaction = '0'
2954 ORDER BY a.acc_trans_id, a.transdate|;
2955 $sth = $dbh->prepare($query);
2956 do_statement($self, $sth, $query, $self->{id});
2958 # get exchangerate for currency
2959 $self->{exchangerate} =
2960 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2963 # store amounts in {acc_trans}{$key} for multiple accounts
2964 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2965 $ref->{exchangerate} =
2966 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2967 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2970 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2971 $ref->{amount} *= -1;
2973 $ref->{index} = $index;
2975 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2981 d.curr AS currencies, d.closedto, d.revtrans,
2982 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2983 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2985 $ref = selectfirst_hashref_query($self, $dbh, $query);
2986 map { $self->{$_} = $ref->{$_} } keys %$ref;
2993 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2994 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2995 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2997 $ref = selectfirst_hashref_query($self, $dbh, $query);
2998 map { $self->{$_} = $ref->{$_} } keys %$ref;
3000 if ($self->{"$self->{vc}_id"}) {
3002 # only setup currency
3003 ($self->{currency}) = split(/:/, $self->{currencies});
3007 $self->lastname_used($dbh, $myconfig, $table, $module);
3009 # get exchangerate for currency
3010 $self->{exchangerate} =
3011 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3017 $main::lxdebug->leave_sub();
3021 $main::lxdebug->enter_sub();
3023 my ($self, $dbh, $myconfig, $table, $module) = @_;
3027 $table = $table eq "customer" ? "customer" : "vendor";
3028 my %column_map = ("a.curr" => "currency",
3029 "a.${table}_id" => "${table}_id",
3030 "a.department_id" => "department_id",
3031 "d.description" => "department",
3032 "ct.name" => $table,
3033 "current_date + ct.terms" => "duedate",
3036 if ($self->{type} =~ /delivery_order/) {
3037 $arap = 'delivery_orders';
3038 delete $column_map{"a.curr"};
3040 } elsif ($self->{type} =~ /_order/) {
3042 $where = "quotation = '0'";
3044 } elsif ($self->{type} =~ /_quotation/) {
3046 $where = "quotation = '1'";
3048 } elsif ($table eq 'customer') {
3056 $where = "($where) AND" if ($where);
3057 my $query = qq|SELECT MAX(id) FROM $arap
3058 WHERE $where ${table}_id > 0|;
3059 my ($trans_id) = selectrow_query($self, $dbh, $query);
3062 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3063 $query = qq|SELECT $column_spec
3065 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3066 LEFT JOIN department d ON (a.department_id = d.id)
3068 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3070 map { $self->{$_} = $ref->{$_} } values %column_map;
3072 $main::lxdebug->leave_sub();
3076 $main::lxdebug->enter_sub();
3079 my $myconfig = shift || \%::myconfig;
3080 my ($thisdate, $days) = @_;
3082 my $dbh = $self->get_standard_dbh($myconfig);
3087 my $dateformat = $myconfig->{dateformat};
3088 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3089 $thisdate = $dbh->quote($thisdate);
3090 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3092 $query = qq|SELECT current_date AS thisdate|;
3095 ($thisdate) = selectrow_query($self, $dbh, $query);
3097 $main::lxdebug->leave_sub();
3103 $main::lxdebug->enter_sub();
3105 my ($self, $string) = @_;
3107 if ($string !~ /%/) {
3108 $string = "%$string%";
3111 $string =~ s/\'/\'\'/g;
3113 $main::lxdebug->leave_sub();
3119 $main::lxdebug->enter_sub();
3121 my ($self, $flds, $new, $count, $numrows) = @_;
3125 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3130 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3132 my $j = $item->{ndx} - 1;
3133 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3137 for $i ($count + 1 .. $numrows) {
3138 map { delete $self->{"${_}_$i"} } @{$flds};
3141 $main::lxdebug->leave_sub();
3145 $main::lxdebug->enter_sub();
3147 my ($self, $myconfig) = @_;
3151 my $dbh = $self->dbconnect_noauto($myconfig);
3153 my $query = qq|DELETE FROM status
3154 WHERE (formname = ?) AND (trans_id = ?)|;
3155 my $sth = prepare_query($self, $dbh, $query);
3157 if ($self->{formname} =~ /(check|receipt)/) {
3158 for $i (1 .. $self->{rowcount}) {
3159 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3162 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3166 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3167 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3169 my %queued = split / /, $self->{queued};
3172 if ($self->{formname} =~ /(check|receipt)/) {
3174 # this is a check or receipt, add one entry for each lineitem
3175 my ($accno) = split /--/, $self->{account};
3176 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3177 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3178 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3179 $sth = prepare_query($self, $dbh, $query);
3181 for $i (1 .. $self->{rowcount}) {
3182 if ($self->{"checked_$i"}) {
3183 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3189 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3190 VALUES (?, ?, ?, ?, ?)|;
3191 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3192 $queued{$self->{formname}}, $self->{formname});
3198 $main::lxdebug->leave_sub();
3202 $main::lxdebug->enter_sub();
3204 my ($self, $dbh) = @_;
3206 my ($query, $printed, $emailed);
3208 my $formnames = $self->{printed};
3209 my $emailforms = $self->{emailed};
3211 $query = qq|DELETE FROM status
3212 WHERE (formname = ?) AND (trans_id = ?)|;
3213 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3215 # this only applies to the forms
3216 # checks and receipts are posted when printed or queued
3218 if ($self->{queued}) {
3219 my %queued = split / /, $self->{queued};
3221 foreach my $formname (keys %queued) {
3222 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3223 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3225 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3226 VALUES (?, ?, ?, ?, ?)|;
3227 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3229 $formnames =~ s/\Q$self->{formname}\E//;
3230 $emailforms =~ s/\Q$self->{formname}\E//;
3235 # save printed, emailed info
3236 $formnames =~ s/^ +//g;
3237 $emailforms =~ s/^ +//g;
3240 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3241 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3243 foreach my $formname (keys %status) {
3244 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3245 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3247 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3248 VALUES (?, ?, ?, ?)|;
3249 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3252 $main::lxdebug->leave_sub();
3256 # $main::locale->text('SAVED')
3257 # $main::locale->text('DELETED')
3258 # $main::locale->text('ADDED')
3259 # $main::locale->text('PAYMENT POSTED')
3260 # $main::locale->text('POSTED')
3261 # $main::locale->text('POSTED AS NEW')
3262 # $main::locale->text('ELSE')
3263 # $main::locale->text('SAVED FOR DUNNING')
3264 # $main::locale->text('DUNNING STARTED')
3265 # $main::locale->text('PRINTED')
3266 # $main::locale->text('MAILED')
3267 # $main::locale->text('SCREENED')
3268 # $main::locale->text('CANCELED')
3269 # $main::locale->text('invoice')
3270 # $main::locale->text('proforma')
3271 # $main::locale->text('sales_order')
3272 # $main::locale->text('pick_list')
3273 # $main::locale->text('purchase_order')
3274 # $main::locale->text('bin_list')
3275 # $main::locale->text('sales_quotation')
3276 # $main::locale->text('request_quotation')
3279 $main::lxdebug->enter_sub();
3282 my $dbh = shift || $self->get_standard_dbh;
3284 if(!exists $self->{employee_id}) {
3285 &get_employee($self, $dbh);
3289 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3290 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3291 my @values = (conv_i($self->{id}), $self->{login},
3292 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3293 do_query($self, $dbh, $query, @values);
3297 $main::lxdebug->leave_sub();
3301 $main::lxdebug->enter_sub();
3303 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3304 my ($orderBy, $desc) = split(/\-\-/, $order);
3305 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3308 if ($trans_id ne "") {
3310 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 | .
3311 qq|FROM history_erp h | .
3312 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3313 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3316 my $sth = $dbh->prepare($query) || $self->dberror($query);
3318 $sth->execute() || $self->dberror("$query");
3320 while(my $hash_ref = $sth->fetchrow_hashref()) {
3321 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3322 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3323 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3324 $tempArray[$i++] = $hash_ref;
3326 $main::lxdebug->leave_sub() and return \@tempArray
3327 if ($i > 0 && $tempArray[0] ne "");
3329 $main::lxdebug->leave_sub();
3333 sub update_defaults {
3334 $main::lxdebug->enter_sub();
3336 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3339 if ($provided_dbh) {
3340 $dbh = $provided_dbh;
3342 $dbh = $self->dbconnect_noauto($myconfig);
3344 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3345 my $sth = $dbh->prepare($query);
3347 $sth->execute || $self->dberror($query);
3348 my ($var) = $sth->fetchrow_array;
3351 if ($var =~ m/\d+$/) {
3352 my $new_var = (substr $var, $-[0]) * 1 + 1;
3353 my $len_diff = length($var) - $-[0] - length($new_var);
3354 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3360 $query = qq|UPDATE defaults SET $fld = ?|;
3361 do_query($self, $dbh, $query, $var);
3363 if (!$provided_dbh) {
3368 $main::lxdebug->leave_sub();
3373 sub update_business {
3374 $main::lxdebug->enter_sub();
3376 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3379 if ($provided_dbh) {
3380 $dbh = $provided_dbh;
3382 $dbh = $self->dbconnect_noauto($myconfig);
3385 qq|SELECT customernumberinit FROM business
3386 WHERE id = ? FOR UPDATE|;
3387 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3389 return undef unless $var;
3391 if ($var =~ m/\d+$/) {
3392 my $new_var = (substr $var, $-[0]) * 1 + 1;
3393 my $len_diff = length($var) - $-[0] - length($new_var);
3394 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3400 $query = qq|UPDATE business
3401 SET customernumberinit = ?
3403 do_query($self, $dbh, $query, $var, $business_id);
3405 if (!$provided_dbh) {
3410 $main::lxdebug->leave_sub();
3415 sub get_partsgroup {
3416 $main::lxdebug->enter_sub();
3418 my ($self, $myconfig, $p) = @_;
3419 my $target = $p->{target} || 'all_partsgroup';
3421 my $dbh = $self->get_standard_dbh($myconfig);
3423 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3425 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3428 if ($p->{searchitems} eq 'part') {
3429 $query .= qq|WHERE p.inventory_accno_id > 0|;
3431 if ($p->{searchitems} eq 'service') {
3432 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3434 if ($p->{searchitems} eq 'assembly') {
3435 $query .= qq|WHERE p.assembly = '1'|;
3437 if ($p->{searchitems} eq 'labor') {
3438 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3441 $query .= qq|ORDER BY partsgroup|;
3444 $query = qq|SELECT id, partsgroup FROM partsgroup
3445 ORDER BY partsgroup|;
3448 if ($p->{language_code}) {
3449 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3450 t.description AS translation
3452 JOIN parts p ON (p.partsgroup_id = pg.id)
3453 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3454 ORDER BY translation|;
3455 @values = ($p->{language_code});
3458 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3460 $main::lxdebug->leave_sub();
3463 sub get_pricegroup {
3464 $main::lxdebug->enter_sub();
3466 my ($self, $myconfig, $p) = @_;
3468 my $dbh = $self->get_standard_dbh($myconfig);
3470 my $query = qq|SELECT p.id, p.pricegroup
3473 $query .= qq| ORDER BY pricegroup|;
3476 $query = qq|SELECT id, pricegroup FROM pricegroup
3477 ORDER BY pricegroup|;
3480 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3482 $main::lxdebug->leave_sub();
3486 # usage $form->all_years($myconfig, [$dbh])
3487 # return list of all years where bookings found
3490 $main::lxdebug->enter_sub();
3492 my ($self, $myconfig, $dbh) = @_;
3494 $dbh ||= $self->get_standard_dbh($myconfig);
3497 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3498 (SELECT MAX(transdate) FROM acc_trans)|;
3499 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3501 if ($myconfig->{dateformat} =~ /^yy/) {
3502 ($startdate) = split /\W/, $startdate;
3503 ($enddate) = split /\W/, $enddate;
3505 (@_) = split /\W/, $startdate;
3507 (@_) = split /\W/, $enddate;
3512 $startdate = substr($startdate,0,4);
3513 $enddate = substr($enddate,0,4);
3515 while ($enddate >= $startdate) {
3516 push @all_years, $enddate--;
3521 $main::lxdebug->leave_sub();
3525 $main::lxdebug->enter_sub();
3529 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3531 $main::lxdebug->leave_sub();
3535 $main::lxdebug->enter_sub();
3540 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3542 $main::lxdebug->leave_sub();
3545 sub prepare_for_printing {
3548 $self->{templates} ||= $::myconfig{templates};
3549 $self->{formname} ||= $self->{type};
3550 $self->{media} ||= 'email';
3552 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3554 # set shipto from billto unless set
3555 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3556 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3557 $self->{shiptoname} = $::myconfig{company};
3558 $self->{shiptostreet} = $::myconfig{address};
3561 my $language = $self->{language} ? '_' . $self->{language} : '';
3563 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3564 if ($self->{language_id}) {
3565 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3567 $output_dateformat = $::myconfig{dateformat};
3568 $output_numberformat = $::myconfig{numberformat};
3569 $output_longdates = 1;
3572 # Retrieve accounts for tax calculation.
3573 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3575 if ($self->{type} =~ /_delivery_order$/) {
3576 DO->order_details();
3577 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3578 OE->order_details(\%::myconfig, $self);
3580 IS->invoice_details(\%::myconfig, $self, $::locale);
3583 # Chose extension & set source file name
3584 my $extension = 'html';
3585 if ($self->{format} eq 'postscript') {
3586 $self->{postscript} = 1;
3588 } elsif ($self->{"format"} =~ /pdf/) {
3590 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3591 } elsif ($self->{"format"} =~ /opendocument/) {
3592 $self->{opendocument} = 1;
3594 } elsif ($self->{"format"} =~ /excel/) {
3599 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3600 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3601 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3604 $self->format_dates($output_dateformat, $output_longdates,
3605 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3606 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3607 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3609 $self->reformat_numbers($output_numberformat, 2,
3610 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3611 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3613 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3615 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3617 if (scalar @{ $cvar_date_fields }) {
3618 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3621 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3622 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3629 my ($self, $dateformat, $longformat, @indices) = @_;
3631 $dateformat ||= $::myconfig{dateformat};
3633 foreach my $idx (@indices) {
3634 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3635 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3636 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3640 next unless defined $self->{$idx};
3642 if (!ref($self->{$idx})) {
3643 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3645 } elsif (ref($self->{$idx}) eq "ARRAY") {
3646 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3647 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3653 sub reformat_numbers {
3654 my ($self, $numberformat, $places, @indices) = @_;
3656 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3658 foreach my $idx (@indices) {
3659 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3660 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3661 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3665 next unless defined $self->{$idx};
3667 if (!ref($self->{$idx})) {
3668 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3670 } elsif (ref($self->{$idx}) eq "ARRAY") {
3671 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3672 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3677 my $saved_numberformat = $::myconfig{numberformat};
3678 $::myconfig{numberformat} = $numberformat;
3680 foreach my $idx (@indices) {
3681 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3682 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3683 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3687 next unless defined $self->{$idx};
3689 if (!ref($self->{$idx})) {
3690 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3692 } elsif (ref($self->{$idx}) eq "ARRAY") {
3693 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3694 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3699 $::myconfig{numberformat} = $saved_numberformat;
3708 SL::Form.pm - main data object.
3712 This is the main data object of Lx-Office.
3713 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3714 Points of interest for a beginner are:
3716 - $form->error - renders a generic error in html. accepts an error message
3717 - $form->get_standard_dbh - returns a database connection for the
3719 =head1 SPECIAL FUNCTIONS
3721 =head2 C<_store_value()>
3723 parses a complex var name, and stores it in the form.
3726 $form->_store_value($key, $value);
3728 keys must start with a string, and can contain various tokens.
3729 supported key structures are:
3732 simple key strings work as expected
3737 separating two keys by a dot (.) will result in a hash lookup for the inner value
3738 this is similar to the behaviour of java and templating mechanisms.
3740 filter.description => $form->{filter}->{description}
3742 3. array+hashref access
3744 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3745 using [+] instead of [] will force a new array index. this is useful for recurring
3746 data structures like part lists. put a [+] into the first varname, and use [] on the
3749 repeating these names in your template:
3752 invoice.items[].parts_id
3756 $form->{invoice}->{items}->[
3770 using brackets at the end of a name will result in a pure array to be created.
3771 note that you mustn't use [+], which is reserved for array+hash access and will
3772 result in undefined behaviour in array context.
3774 filter.status[] => $form->{status}->[ val1, val2, ... ]
3776 =head2 C<update_business> PARAMS
3779 \%config, - config hashref
3780 $business_id, - business id
3781 $dbh - optional database handle
3783 handles business (thats customer/vendor types) sequences.
3785 special behaviour for empty strings in customerinitnumber field:
3786 will in this case not increase the value, and return undef.
3788 =head2 C<redirect_header> $url
3790 Generates a HTTP redirection header for the new C<$url>. Constructs an
3791 absolute URL including scheme, host name and port. If C<$url> is a
3792 relative URL then it is considered relative to Lx-Office base URL.
3794 This function C<die>s if headers have already been created with
3795 C<$::form-E<gt>header>.
3799 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3800 print $::form->redirect_header('http://www.lx-office.org/');
3804 Generates a general purpose http/html header and includes most of the scripts
3805 ans stylesheets needed.
3807 Only one header will be generated. If the method was already called in this
3808 request it will not output anything and return undef. Also if no
3809 HTTP_USER_AGENT is found, no header is generated.
3811 Although header does not accept parameters itself, it will honor special
3812 hashkeys of its Form instance:
3820 If one of these is set, a http-equiv refresh is generated. Missing parameters
3821 default to 3 seconds and the refering url.
3827 If these are arrayrefs the contents will be inlined into the header.
3831 If true, a css snippet will be generated that sets the page in landscape mode.
3835 Used to override the default favicon.
3839 A html page title will be generated from this