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);
137 if (!$ENV{'CONTENT_TYPE'}
138 || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
140 $self->_input_to_hash($input);
142 $main::lxdebug->leave_sub(2);
146 my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
148 my $boundary = '--' . $1;
150 foreach my $line (split m/\n/, $input) {
151 last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
153 if (($line eq $boundary) || ($line eq "$boundary\r")) {
154 ${ $previous } =~ s|\r?\n$|| if $previous;
160 $content_type = "text/plain";
167 next unless $boundary_found;
169 if (!$headers_done) {
170 $line =~ s/[\r\n]*$//;
177 if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
178 if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
180 substr $line, $-[0], $+[0] - $-[0], "";
183 if ($line =~ m|name\s*=\s*"(.*?)"|i) {
185 substr $line, $-[0], $+[0] - $-[0], "";
188 $previous = $self->_store_value($name, '') if ($name);
189 $self->{FILENAME} = $filename if ($filename);
194 if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
201 next unless $previous;
203 ${ $previous } .= "${line}\n";
206 ${ $previous } =~ s|\r?\n$|| if $previous;
208 $main::lxdebug->leave_sub(2);
211 sub _recode_recursively {
212 $main::lxdebug->enter_sub();
213 my ($iconv, $param) = @_;
215 if (any { ref $param eq $_ } qw(Form HASH)) {
216 foreach my $key (keys %{ $param }) {
217 if (!ref $param->{$key}) {
218 # Workaround for a bug: converting $param->{$key} directly
219 # leads to 'undef'. I don't know why. Converting a copy works,
221 $param->{$key} = $iconv->convert("" . $param->{$key});
223 _recode_recursively($iconv, $param->{$key});
227 } elsif (ref $param eq 'ARRAY') {
228 foreach my $idx (0 .. scalar(@{ $param }) - 1) {
229 if (!ref $param->[$idx]) {
230 # Workaround for a bug: converting $param->[$idx] directly
231 # leads to 'undef'. I don't know why. Converting a copy works,
233 $param->[$idx] = $iconv->convert("" . $param->[$idx]);
235 _recode_recursively($iconv, $param->[$idx]);
239 $main::lxdebug->leave_sub();
243 $main::lxdebug->enter_sub();
249 if ($LXDebug::watch_form) {
250 require SL::Watchdog;
251 tie %{ $self }, 'SL::Watchdog';
256 $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
257 $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0];
259 if ($ENV{CONTENT_LENGTH}) {
261 read STDIN, $content, $ENV{CONTENT_LENGTH};
262 $self->_request_to_hash($content);
265 my $db_charset = $::lx_office_conf{system}->{dbcharset};
266 $db_charset ||= Common::DEFAULT_CHARSET;
268 my $encoding = $self->{INPUT_ENCODING} || $db_charset;
269 delete $self->{INPUT_ENCODING};
271 _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self);
273 #$self->{version} = "2.6.1"; # Old hardcoded but secure style
274 open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file
275 $self->{version} = <VERSION_FILE>;
277 $self->{version} =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code.
279 $main::lxdebug->leave_sub();
284 sub _flatten_variables_rec {
285 $main::lxdebug->enter_sub(2);
294 if ('' eq ref $curr->{$key}) {
295 @result = ({ 'key' => $prefix . $key, 'value' => $curr->{$key} });
297 } elsif ('HASH' eq ref $curr->{$key}) {
298 foreach my $hash_key (sort keys %{ $curr->{$key} }) {
299 push @result, $self->_flatten_variables_rec($curr->{$key}, $prefix . $key . '.', $hash_key);
303 foreach my $idx (0 .. scalar @{ $curr->{$key} } - 1) {
304 my $first_array_entry = 1;
306 foreach my $hash_key (sort keys %{ $curr->{$key}->[$idx] }) {
307 push @result, $self->_flatten_variables_rec($curr->{$key}->[$idx], $prefix . $key . ($first_array_entry ? '[+].' : '[].'), $hash_key);
308 $first_array_entry = 0;
313 $main::lxdebug->leave_sub(2);
318 sub flatten_variables {
319 $main::lxdebug->enter_sub(2);
327 push @variables, $self->_flatten_variables_rec($self, '', $_);
330 $main::lxdebug->leave_sub(2);
335 sub flatten_standard_variables {
336 $main::lxdebug->enter_sub(2);
339 my %skip_keys = map { $_ => 1 } (qw(login password header stylesheet titlebar version), @_);
343 foreach (grep { ! $skip_keys{$_} } keys %{ $self }) {
344 push @variables, $self->_flatten_variables_rec($self, '', $_);
347 $main::lxdebug->leave_sub(2);
353 $main::lxdebug->enter_sub();
359 map { print "$_ = $self->{$_}\n" } (sort keys %{$self});
361 $main::lxdebug->leave_sub();
365 $main::lxdebug->enter_sub(2);
368 my $password = $self->{password};
370 $self->{password} = 'X' x 8;
372 local $Data::Dumper::Sortkeys = 1;
373 my $output = Dumper($self);
375 $self->{password} = $password;
377 $main::lxdebug->leave_sub(2);
383 $main::lxdebug->enter_sub(2);
385 my ($self, $str) = @_;
387 $str = Encode::encode('utf-8-strict', $str) if $::locale->is_utf8;
388 $str =~ s/([^a-zA-Z0-9_.:-])/sprintf("%%%02x", ord($1))/ge;
390 $main::lxdebug->leave_sub(2);
396 $main::lxdebug->enter_sub(2);
398 my ($self, $str) = @_;
403 $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
404 $str = Encode::decode('utf-8-strict', $str) if $::locale->is_utf8;
406 $main::lxdebug->leave_sub(2);
412 $main::lxdebug->enter_sub();
413 my ($self, $str) = @_;
415 if ($str && !ref($str)) {
416 $str =~ s/\"/"/g;
419 $main::lxdebug->leave_sub();
425 $main::lxdebug->enter_sub();
426 my ($self, $str) = @_;
428 if ($str && !ref($str)) {
429 $str =~ s/"/\"/g;
432 $main::lxdebug->leave_sub();
438 $main::lxdebug->enter_sub();
442 map({ print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_);
444 for (sort keys %$self) {
445 next if (($_ eq "header") || (ref($self->{$_}) ne ""));
446 print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n");
449 $main::lxdebug->leave_sub();
453 my ($self, $code) = @_;
454 local $self->{__ERROR_HANDLER} = sub { die({ error => $_[0] }) };
459 $main::lxdebug->enter_sub();
461 $main::lxdebug->show_backtrace();
463 my ($self, $msg) = @_;
465 if ($self->{__ERROR_HANDLER}) {
466 $self->{__ERROR_HANDLER}->($msg);
468 } elsif ($ENV{HTTP_USER_AGENT}) {
470 $self->show_generic_error($msg);
473 print STDERR "Error: $msg\n";
477 $main::lxdebug->leave_sub();
481 $main::lxdebug->enter_sub();
483 my ($self, $msg) = @_;
485 if ($ENV{HTTP_USER_AGENT}) {
488 if (!$self->{header}) {
494 <p class="message_ok"><b>$msg</b></p>
496 <script type="text/javascript">
498 // If JavaScript is enabled, the whole thing will be reloaded.
499 // The reason is: When one changes his menu setup (HTML / XUL / CSS ...)
500 // it now loads the correct code into the browser instead of do nothing.
501 setTimeout("top.frames.location.href='login.pl'",500);
510 if ($self->{info_function}) {
511 &{ $self->{info_function} }($msg);
517 $main::lxdebug->leave_sub();
520 # calculates the number of rows in a textarea based on the content and column number
521 # can be capped with maxrows
523 $main::lxdebug->enter_sub();
524 my ($self, $str, $cols, $maxrows, $minrows) = @_;
528 my $rows = sum map { int((length() - 2) / $cols) + 1 } split /\r/, $str;
531 $main::lxdebug->leave_sub();
533 return max(min($rows, $maxrows), $minrows);
537 $main::lxdebug->enter_sub();
539 my ($self, $msg) = @_;
541 $self->error("$msg\n" . $DBI::errstr);
543 $main::lxdebug->leave_sub();
547 $main::lxdebug->enter_sub();
549 my ($self, $name, $msg) = @_;
552 foreach my $part (split m/\./, $name) {
553 if (!$curr->{$part} || ($curr->{$part} =~ /^\s*$/)) {
556 $curr = $curr->{$part};
559 $main::lxdebug->leave_sub();
562 sub _get_request_uri {
565 return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
567 my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http';
568 my $port = $ENV{SERVER_PORT} || '';
569 $port = undef if (($scheme eq 'http' ) && ($port == 80))
570 || (($scheme eq 'https') && ($port == 443));
572 my $uri = URI->new("${scheme}://");
573 $uri->scheme($scheme);
575 $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
576 $uri->path_query($ENV{REQUEST_URI});
582 sub _add_to_request_uri {
585 my $relative_new_path = shift;
586 my $request_uri = shift || $self->_get_request_uri;
587 my $relative_new_uri = URI->new($relative_new_path);
588 my @request_segments = $request_uri->path_segments;
590 my $new_uri = $request_uri->clone;
591 $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments);
596 sub create_http_response {
597 $main::lxdebug->enter_sub();
602 my $cgi = $main::cgi;
603 $cgi ||= CGI->new('');
606 if (defined $main::auth) {
607 my $uri = $self->_get_request_uri;
608 my @segments = $uri->path_segments;
610 $uri->path_segments(@segments);
612 my $session_cookie_value = $main::auth->get_session_id();
614 if ($session_cookie_value) {
615 $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
616 '-value' => $session_cookie_value,
617 '-path' => $uri->path,
618 '-secure' => $ENV{HTTPS});
622 my %cgi_params = ('-type' => $params{content_type});
623 $cgi_params{'-charset'} = $params{charset} if ($params{charset});
624 $cgi_params{'-cookie'} = $session_cookie if ($session_cookie);
626 my $output = $cgi->header(%cgi_params);
628 $main::lxdebug->leave_sub();
635 $::lxdebug->enter_sub;
637 # extra code is currently only used by menuv3 and menuv4 to set their css.
638 # it is strongly deprecated, and will be changed in a future version.
639 my ($self, $extra_code) = @_;
640 my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
643 $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
645 $self->{favicon} ||= "favicon.ico";
646 $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title};
649 if ($self->{refresh_url} || $self->{refresh_time}) {
650 my $refresh_time = $self->{refresh_time} || 3;
651 my $refresh_url = $self->{refresh_url} || $ENV{REFERER};
652 push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
655 push @header, "<link rel='stylesheet' href='css/$_' type='text/css' title='Lx-Office stylesheet'>"
656 for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets};
658 push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
659 push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
660 push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
661 '<script type="text/javascript" src="js/common.js"></script>',
662 '<style type="text/css">@import url(js/jscalendar/calendar-win2k-1.css);</style>',
663 '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
664 '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
665 '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
666 '<script type="text/javascript" src="js/part_selection.js"></script>';
667 push @header, $self->{javascript} if $self->{javascript};
668 push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
669 push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
670 push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
671 join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title};
673 # if there is a title, we put some JavaScript in to the page, wich writes a
674 # meaningful title-tag for our frameset.
676 if ($self->{title}) {
678 <script type="text/javascript">
680 // Write a meaningful title-tag for our frameset.
681 top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
687 print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
688 print "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01//EN' 'http://www.w3.org/TR/html4/strict.dtd'>\n"
689 if $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/; # Other browsers may choke on menu scripts with DOCTYPE.
693 <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
694 <title>$self->{titlebar}</title>
696 print " $_\n" for @header;
698 <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css" />
699 <meta name="robots" content="noindex,nofollow" />
700 <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
701 <script type="text/javascript" src="js/tabcontent.js">
703 /***********************************************
704 * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
705 * This notice MUST stay intact for legal use
706 * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
707 ***********************************************/
716 $::lxdebug->leave_sub;
719 sub ajax_response_header {
720 $main::lxdebug->enter_sub();
724 my $db_charset = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
725 my $cgi = $main::cgi || CGI->new('');
726 my $output = $cgi->header('-charset' => $db_charset);
728 $main::lxdebug->leave_sub();
733 sub redirect_header {
737 my $base_uri = $self->_get_request_uri;
738 my $new_uri = URI->new_abs($new_url, $base_uri);
740 die "Headers already sent" if $::self->{header};
743 my $cgi = $main::cgi || CGI->new('');
744 return $cgi->redirect($new_uri);
747 sub set_standard_title {
748 $::lxdebug->enter_sub;
751 $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
752 $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
753 $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
755 $::lxdebug->leave_sub;
758 sub _prepare_html_template {
759 $main::lxdebug->enter_sub();
761 my ($self, $file, $additional_params) = @_;
764 if (!%::myconfig || !$::myconfig{"countrycode"}) {
765 $language = $::lx_office_conf{system}->{language};
767 $language = $main::myconfig{"countrycode"};
769 $language = "de" unless ($language);
771 if (-f "templates/webpages/${file}.html") {
772 if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
773 my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
774 "Please re-run 'locales.pl' in 'locale/${language}'.";
775 print(qq|<pre>$info</pre>|);
779 $file = "templates/webpages/${file}.html";
782 my $info = "Web page template '${file}' not found.\n";
783 print qq|<pre>$info</pre>|;
787 if ($self->{"DEBUG"}) {
788 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
791 if ($additional_params->{"DEBUG"}) {
792 $additional_params->{"DEBUG"} =
793 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
796 if (%main::myconfig) {
797 $::myconfig{jsc_dateformat} = apply {
801 } $::myconfig{"dateformat"};
802 $additional_params->{"myconfig"} ||= \%::myconfig;
803 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
806 $additional_params->{"conf_dbcharset"} = $::lx_office_conf{system}->{dbcharset};
807 $additional_params->{"conf_webdav"} = $::lx_office_conf{system}->{webdav};
808 $additional_params->{"conf_lizenzen"} = $::lx_office_conf{system}->{lizenzen};
809 $additional_params->{"conf_latex_templates"} = $::lx_office_conf{print_templates}->{latex};
810 $additional_params->{"conf_opendocument_templates"} = $::lx_office_conf{print_templates}->{opendocument};
811 $additional_params->{"conf_vertreter"} = $::lx_office_conf{system}->{vertreter};
812 $additional_params->{"conf_show_best_before"} = $::lx_office_conf{system}->{show_best_before};
813 $additional_params->{"conf_parts_image_css"} = $::lx_office_conf{features}->{parts_image_css};
814 $additional_params->{"conf_parts_listing_images"} = $::lx_office_conf{features}->{parts_listing_images};
815 $additional_params->{"conf_parts_show_image"} = $::lx_office_conf{features}->{parts_show_image};
817 if (%main::debug_options) {
818 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
821 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
822 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
823 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
827 $main::lxdebug->leave_sub();
832 sub parse_html_template {
833 $main::lxdebug->enter_sub();
835 my ($self, $file, $additional_params) = @_;
837 $additional_params ||= { };
839 my $real_file = $self->_prepare_html_template($file, $additional_params);
840 my $template = $self->template || $self->init_template;
842 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
845 $template->process($real_file, $additional_params, \$output) || die $template->error;
847 $main::lxdebug->leave_sub();
855 return if $self->template;
857 return $self->template(Template->new({
862 'PLUGIN_BASE' => 'SL::Template::Plugin',
863 'INCLUDE_PATH' => '.:templates/webpages',
864 'COMPILE_EXT' => '.tcc',
865 'COMPILE_DIR' => $::lx_office_conf{paths}->{userspath} . '/templates-cache',
871 $self->{template_object} = shift if @_;
872 return $self->{template_object};
875 sub show_generic_error {
876 $main::lxdebug->enter_sub();
878 my ($self, $error, %params) = @_;
880 if ($self->{__ERROR_HANDLER}) {
881 $self->{__ERROR_HANDLER}->($error);
882 $main::lxdebug->leave_sub();
887 'title_error' => $params{title},
888 'label_error' => $error,
891 if ($params{action}) {
894 map { delete($self->{$_}); } qw(action);
895 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
897 $add_params->{SHOW_BUTTON} = 1;
898 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
899 $add_params->{VARIABLES} = \@vars;
901 } elsif ($params{back_button}) {
902 $add_params->{SHOW_BACK_BUTTON} = 1;
905 $self->{title} = $params{title} if $params{title};
908 print $self->parse_html_template("generic/error", $add_params);
910 print STDERR "Error: $error\n";
912 $main::lxdebug->leave_sub();
917 sub show_generic_information {
918 $main::lxdebug->enter_sub();
920 my ($self, $text, $title) = @_;
923 'title_information' => $title,
924 'label_information' => $text,
927 $self->{title} = $title if ($title);
930 print $self->parse_html_template("generic/information", $add_params);
932 $main::lxdebug->leave_sub();
937 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
938 # changed it to accept an arbitrary number of triggers - sschoeling
940 $main::lxdebug->enter_sub();
943 my $myconfig = shift;
946 # set dateform for jsscript
949 "dd.mm.yy" => "%d.%m.%Y",
950 "dd-mm-yy" => "%d-%m-%Y",
951 "dd/mm/yy" => "%d/%m/%Y",
952 "mm/dd/yy" => "%m/%d/%Y",
953 "mm-dd-yy" => "%m-%d-%Y",
954 "yyyy-mm-dd" => "%Y-%m-%d",
957 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
958 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
965 inputField : "| . (shift) . qq|",
966 ifFormat :"$ifFormat",
967 align : "| . (shift) . qq|",
968 button : "| . (shift) . qq|"
974 <script type="text/javascript">
975 <!--| . join("", @triggers) . qq|//-->
979 $main::lxdebug->leave_sub();
982 } #end sub write_trigger
985 $main::lxdebug->enter_sub();
987 my ($self, $msg) = @_;
989 if (!$self->{callback}) {
995 # my ($script, $argv) = split(/\?/, $self->{callback}, 2);
996 # $script =~ s|.*/||;
997 # $script =~ s|[^a-zA-Z0-9_\.]||g;
998 # exec("perl", "$script", $argv);
1000 print $::form->redirect_header($self->{callback});
1002 $main::lxdebug->leave_sub();
1005 # sort of columns removed - empty sub
1007 $main::lxdebug->enter_sub();
1009 my ($self, @columns) = @_;
1011 $main::lxdebug->leave_sub();
1017 $main::lxdebug->enter_sub(2);
1019 my ($self, $myconfig, $amount, $places, $dash) = @_;
1021 if ($amount eq "") {
1025 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1027 my $neg = ($amount =~ s/^-//);
1028 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1030 if (defined($places) && ($places ne '')) {
1036 my ($actual_places) = ($amount =~ /\.(\d+)/);
1037 $actual_places = length($actual_places);
1038 $places = $actual_places > $places ? $actual_places : $places;
1041 $amount = $self->round_amount($amount, $places);
1044 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1045 my @p = split(/\./, $amount); # split amount at decimal point
1047 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1050 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1053 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1054 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1055 ($neg ? "-$amount" : "$amount" ) ;
1059 $main::lxdebug->leave_sub(2);
1063 sub format_amount_units {
1064 $main::lxdebug->enter_sub();
1069 my $myconfig = \%main::myconfig;
1070 my $amount = $params{amount} * 1;
1071 my $places = $params{places};
1072 my $part_unit_name = $params{part_unit};
1073 my $amount_unit_name = $params{amount_unit};
1074 my $conv_units = $params{conv_units};
1075 my $max_places = $params{max_places};
1077 if (!$part_unit_name) {
1078 $main::lxdebug->leave_sub();
1082 AM->retrieve_all_units();
1083 my $all_units = $main::all_units;
1085 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1086 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1089 if (!scalar @{ $conv_units }) {
1090 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1091 $main::lxdebug->leave_sub();
1095 my $part_unit = $all_units->{$part_unit_name};
1096 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1098 $amount *= $conv_unit->{factor};
1103 foreach my $unit (@$conv_units) {
1104 my $last = $unit->{name} eq $part_unit->{name};
1106 $num = int($amount / $unit->{factor});
1107 $amount -= $num * $unit->{factor};
1110 if ($last ? $amount : $num) {
1111 push @values, { "unit" => $unit->{name},
1112 "amount" => $last ? $amount / $unit->{factor} : $num,
1113 "places" => $last ? $places : 0 };
1120 push @values, { "unit" => $part_unit_name,
1125 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1127 $main::lxdebug->leave_sub();
1133 $main::lxdebug->enter_sub(2);
1138 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1139 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1140 $input =~ s/\#\#/\#/g;
1142 $main::lxdebug->leave_sub(2);
1150 $main::lxdebug->enter_sub(2);
1152 my ($self, $myconfig, $amount) = @_;
1154 if ( ($myconfig->{numberformat} eq '1.000,00')
1155 || ($myconfig->{numberformat} eq '1000,00')) {
1160 if ($myconfig->{numberformat} eq "1'000.00") {
1166 $main::lxdebug->leave_sub(2);
1168 return ($amount * 1);
1172 $main::lxdebug->enter_sub(2);
1174 my ($self, $amount, $places) = @_;
1177 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1179 # Round amounts to eight places before rounding to the requested
1180 # number of places. This gets rid of errors due to internal floating
1181 # point representation.
1182 $amount = $self->round_amount($amount, 8) if $places < 8;
1183 $amount = $amount * (10**($places));
1184 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1186 $main::lxdebug->leave_sub(2);
1188 return $round_amount;
1192 sub parse_template {
1193 $main::lxdebug->enter_sub();
1195 my ($self, $myconfig) = @_;
1200 my $userspath = $::lx_office_conf{paths}->{userspath};
1202 $self->{"cwd"} = getcwd();
1203 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1208 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1209 $template_type = 'OpenDocument';
1210 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1212 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1213 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1214 $template_type = 'LaTeX';
1215 $ext_for_format = 'pdf';
1217 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1218 $template_type = 'HTML';
1219 $ext_for_format = 'html';
1221 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1222 $template_type = 'XML';
1223 $ext_for_format = 'xml';
1225 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1226 $template_type = 'XML';
1228 } elsif ( $self->{"format"} =~ /excel/i ) {
1229 $template_type = 'Excel';
1230 $ext_for_format = 'xls';
1232 } elsif ( defined $self->{'format'}) {
1233 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1235 } elsif ( $self->{'format'} eq '' ) {
1236 $self->error("No Outputformat given: $self->{'format'}");
1238 } else { #Catch the rest
1239 $self->error("Outputformat not defined: $self->{'format'}");
1242 my $template = SL::Template::create(type => $template_type,
1243 file_name => $self->{IN},
1245 myconfig => $myconfig,
1246 userspath => $userspath);
1248 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1249 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1251 if (!$self->{employee_id}) {
1252 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1255 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1256 map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1258 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1260 # OUT is used for the media, screen, printer, email
1261 # for postscript we store a copy in a temporary file
1263 my $prepend_userspath;
1265 if (!$self->{tmpfile}) {
1266 $self->{tmpfile} = "${fileid}.$self->{IN}";
1267 $prepend_userspath = 1;
1270 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1272 $self->{tmpfile} =~ s|.*/||;
1273 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1274 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1276 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1277 $out = $self->{OUT};
1278 $self->{OUT} = ">$self->{tmpfile}";
1284 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1285 $result = $template->parse(*OUT);
1290 $result = $template->parse(*STDOUT);
1295 $self->error("$self->{IN} : " . $template->get_error());
1298 if ($self->{media} eq 'file') {
1299 copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1301 chdir("$self->{cwd}");
1303 $::lxdebug->leave_sub();
1308 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1310 if ($self->{media} eq 'email') {
1312 my $mail = new Mailer;
1314 map { $mail->{$_} = $self->{$_} }
1315 qw(cc bcc subject message version format);
1316 $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1317 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1318 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1319 $mail->{fileid} = "$fileid.";
1320 $myconfig->{signature} =~ s/\r//g;
1322 # if we send html or plain text inline
1323 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1324 $mail->{contenttype} = "text/html";
1326 $mail->{message} =~ s/\r//g;
1327 $mail->{message} =~ s/\n/<br>\n/g;
1328 $myconfig->{signature} =~ s/\n/<br>\n/g;
1329 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1331 open(IN, $self->{tmpfile})
1332 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1334 $mail->{message} .= $_;
1341 if (!$self->{"do_not_attach"}) {
1342 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1343 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1344 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1345 "name" => $attachment_name }];
1348 $mail->{message} =~ s/\r//g;
1349 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1353 my $err = $mail->send();
1354 $self->error($self->cleanup . "$err") if ($err);
1358 $self->{OUT} = $out;
1360 my $numbytes = (-s $self->{tmpfile});
1361 open(IN, $self->{tmpfile})
1362 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1365 $self->{copies} = 1 unless $self->{media} eq 'printer';
1367 chdir("$self->{cwd}");
1368 #print(STDERR "Kopien $self->{copies}\n");
1369 #print(STDERR "OUT $self->{OUT}\n");
1370 for my $i (1 .. $self->{copies}) {
1372 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1373 print OUT while <IN>;
1378 $self->{attachment_filename} = ($self->{attachment_filename})
1379 ? $self->{attachment_filename}
1380 : $self->generate_attachment_filename();
1382 # launch application
1383 print qq|Content-Type: | . $template->get_mime_type() . qq|
1384 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1385 Content-Length: $numbytes
1389 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1400 chdir("$self->{cwd}");
1401 $main::lxdebug->leave_sub();
1404 sub get_formname_translation {
1405 $main::lxdebug->enter_sub();
1406 my ($self, $formname) = @_;
1408 $formname ||= $self->{formname};
1410 my %formname_translations = (
1411 bin_list => $main::locale->text('Bin List'),
1412 credit_note => $main::locale->text('Credit Note'),
1413 invoice => $main::locale->text('Invoice'),
1414 pick_list => $main::locale->text('Pick List'),
1415 proforma => $main::locale->text('Proforma Invoice'),
1416 purchase_order => $main::locale->text('Purchase Order'),
1417 request_quotation => $main::locale->text('RFQ'),
1418 sales_order => $main::locale->text('Confirmation'),
1419 sales_quotation => $main::locale->text('Quotation'),
1420 storno_invoice => $main::locale->text('Storno Invoice'),
1421 sales_delivery_order => $main::locale->text('Delivery Order'),
1422 purchase_delivery_order => $main::locale->text('Delivery Order'),
1423 dunning => $main::locale->text('Dunning'),
1426 $main::lxdebug->leave_sub();
1427 return $formname_translations{$formname}
1430 sub get_number_prefix_for_type {
1431 $main::lxdebug->enter_sub();
1435 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1436 : ($self->{type} =~ /_quotation$/) ? 'quo'
1437 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1440 $main::lxdebug->leave_sub();
1444 sub get_extension_for_format {
1445 $main::lxdebug->enter_sub();
1448 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1449 : $self->{format} =~ /postscript/i ? ".ps"
1450 : $self->{format} =~ /opendocument/i ? ".odt"
1451 : $self->{format} =~ /excel/i ? ".xls"
1452 : $self->{format} =~ /html/i ? ".html"
1455 $main::lxdebug->leave_sub();
1459 sub generate_attachment_filename {
1460 $main::lxdebug->enter_sub();
1463 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1464 my $prefix = $self->get_number_prefix_for_type();
1466 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1467 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1469 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1470 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1473 $attachment_filename = "";
1476 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1477 $attachment_filename =~ s|[\s/\\]+|_|g;
1479 $main::lxdebug->leave_sub();
1480 return $attachment_filename;
1483 sub generate_email_subject {
1484 $main::lxdebug->enter_sub();
1487 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1488 my $prefix = $self->get_number_prefix_for_type();
1490 if ($subject && $self->{"${prefix}number"}) {
1491 $subject .= " " . $self->{"${prefix}number"}
1494 $main::lxdebug->leave_sub();
1499 $main::lxdebug->enter_sub();
1503 chdir("$self->{tmpdir}");
1506 if (-f "$self->{tmpfile}.err") {
1507 open(FH, "$self->{tmpfile}.err");
1512 if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1513 $self->{tmpfile} =~ s|.*/||g;
1515 $self->{tmpfile} =~ s/\.\w+$//g;
1516 my $tmpfile = $self->{tmpfile};
1517 unlink(<$tmpfile.*>);
1520 chdir("$self->{cwd}");
1522 $main::lxdebug->leave_sub();
1528 $main::lxdebug->enter_sub();
1530 my ($self, $date, $myconfig) = @_;
1533 if ($date && $date =~ /\D/) {
1535 if ($myconfig->{dateformat} =~ /^yy/) {
1536 ($yy, $mm, $dd) = split /\D/, $date;
1538 if ($myconfig->{dateformat} =~ /^mm/) {
1539 ($mm, $dd, $yy) = split /\D/, $date;
1541 if ($myconfig->{dateformat} =~ /^dd/) {
1542 ($dd, $mm, $yy) = split /\D/, $date;
1547 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1548 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1550 $dd = "0$dd" if ($dd < 10);
1551 $mm = "0$mm" if ($mm < 10);
1553 $date = "$yy$mm$dd";
1556 $main::lxdebug->leave_sub();
1561 # Database routines used throughout
1563 sub _dbconnect_options {
1565 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1572 $main::lxdebug->enter_sub(2);
1574 my ($self, $myconfig) = @_;
1576 # connect to database
1577 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1581 if ($myconfig->{dboptions}) {
1582 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1585 $main::lxdebug->leave_sub(2);
1590 sub dbconnect_noauto {
1591 $main::lxdebug->enter_sub();
1593 my ($self, $myconfig) = @_;
1595 # connect to database
1596 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1600 if ($myconfig->{dboptions}) {
1601 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1604 $main::lxdebug->leave_sub();
1609 sub get_standard_dbh {
1610 $main::lxdebug->enter_sub(2);
1613 my $myconfig = shift || \%::myconfig;
1615 if ($standard_dbh && !$standard_dbh->{Active}) {
1616 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1617 undef $standard_dbh;
1620 $standard_dbh ||= $self->dbconnect_noauto($myconfig);
1622 $main::lxdebug->leave_sub(2);
1624 return $standard_dbh;
1628 $main::lxdebug->enter_sub();
1630 my ($self, $date, $myconfig) = @_;
1631 my $dbh = $self->dbconnect($myconfig);
1633 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1634 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1635 my ($closed) = $sth->fetchrow_array;
1637 $main::lxdebug->leave_sub();
1642 sub update_balance {
1643 $main::lxdebug->enter_sub();
1645 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1647 # if we have a value, go do it
1650 # retrieve balance from table
1651 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1652 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1653 my ($balance) = $sth->fetchrow_array;
1659 $query = "UPDATE $table SET $field = $balance WHERE $where";
1660 do_query($self, $dbh, $query, @values);
1662 $main::lxdebug->leave_sub();
1665 sub update_exchangerate {
1666 $main::lxdebug->enter_sub();
1668 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1670 # some sanity check for currency
1672 $main::lxdebug->leave_sub();
1675 $query = qq|SELECT curr FROM defaults|;
1677 my ($currency) = selectrow_query($self, $dbh, $query);
1678 my ($defaultcurrency) = split m/:/, $currency;
1681 if ($curr eq $defaultcurrency) {
1682 $main::lxdebug->leave_sub();
1686 $query = qq|SELECT e.curr FROM exchangerate e
1687 WHERE e.curr = ? AND e.transdate = ?
1689 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1698 $buy = conv_i($buy, "NULL");
1699 $sell = conv_i($sell, "NULL");
1702 if ($buy != 0 && $sell != 0) {
1703 $set = "buy = $buy, sell = $sell";
1704 } elsif ($buy != 0) {
1705 $set = "buy = $buy";
1706 } elsif ($sell != 0) {
1707 $set = "sell = $sell";
1710 if ($sth->fetchrow_array) {
1711 $query = qq|UPDATE exchangerate
1717 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1718 VALUES (?, $buy, $sell, ?)|;
1721 do_query($self, $dbh, $query, $curr, $transdate);
1723 $main::lxdebug->leave_sub();
1726 sub save_exchangerate {
1727 $main::lxdebug->enter_sub();
1729 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1731 my $dbh = $self->dbconnect($myconfig);
1735 $buy = $rate if $fld eq 'buy';
1736 $sell = $rate if $fld eq 'sell';
1739 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1744 $main::lxdebug->leave_sub();
1747 sub get_exchangerate {
1748 $main::lxdebug->enter_sub();
1750 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1753 unless ($transdate) {
1754 $main::lxdebug->leave_sub();
1758 $query = qq|SELECT curr FROM defaults|;
1760 my ($currency) = selectrow_query($self, $dbh, $query);
1761 my ($defaultcurrency) = split m/:/, $currency;
1763 if ($currency eq $defaultcurrency) {
1764 $main::lxdebug->leave_sub();
1768 $query = qq|SELECT e.$fld FROM exchangerate e
1769 WHERE e.curr = ? AND e.transdate = ?|;
1770 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1774 $main::lxdebug->leave_sub();
1776 return $exchangerate;
1779 sub check_exchangerate {
1780 $main::lxdebug->enter_sub();
1782 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1784 if ($fld !~/^buy|sell$/) {
1785 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1788 unless ($transdate) {
1789 $main::lxdebug->leave_sub();
1793 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1795 if ($currency eq $defaultcurrency) {
1796 $main::lxdebug->leave_sub();
1800 my $dbh = $self->get_standard_dbh($myconfig);
1801 my $query = qq|SELECT e.$fld FROM exchangerate e
1802 WHERE e.curr = ? AND e.transdate = ?|;
1804 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1806 $main::lxdebug->leave_sub();
1808 return $exchangerate;
1811 sub get_all_currencies {
1812 $main::lxdebug->enter_sub();
1815 my $myconfig = shift || \%::myconfig;
1816 my $dbh = $self->get_standard_dbh($myconfig);
1818 my $query = qq|SELECT curr FROM defaults|;
1820 my ($curr) = selectrow_query($self, $dbh, $query);
1821 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1823 $main::lxdebug->leave_sub();
1828 sub get_default_currency {
1829 $main::lxdebug->enter_sub();
1831 my ($self, $myconfig) = @_;
1832 my @currencies = $self->get_all_currencies($myconfig);
1834 $main::lxdebug->leave_sub();
1836 return $currencies[0];
1839 sub set_payment_options {
1840 $main::lxdebug->enter_sub();
1842 my ($self, $myconfig, $transdate) = @_;
1844 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1846 my $dbh = $self->get_standard_dbh($myconfig);
1849 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1850 qq|FROM payment_terms p | .
1853 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1854 $self->{payment_terms}) =
1855 selectrow_query($self, $dbh, $query, $self->{payment_id});
1857 if ($transdate eq "") {
1858 if ($self->{invdate}) {
1859 $transdate = $self->{invdate};
1861 $transdate = $self->{transdate};
1866 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1867 qq|FROM payment_terms|;
1868 ($self->{netto_date}, $self->{skonto_date}) =
1869 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1871 my ($invtotal, $total);
1872 my (%amounts, %formatted_amounts);
1874 if ($self->{type} =~ /_order$/) {
1875 $amounts{invtotal} = $self->{ordtotal};
1876 $amounts{total} = $self->{ordtotal};
1878 } elsif ($self->{type} =~ /_quotation$/) {
1879 $amounts{invtotal} = $self->{quototal};
1880 $amounts{total} = $self->{quototal};
1883 $amounts{invtotal} = $self->{invtotal};
1884 $amounts{total} = $self->{total};
1886 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1888 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1890 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1891 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1892 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1894 foreach (keys %amounts) {
1895 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1896 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1899 if ($self->{"language_id"}) {
1901 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1902 qq|FROM translation_payment_terms t | .
1903 qq|LEFT JOIN language l ON t.language_id = l.id | .
1904 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1905 my ($description_long, $output_numberformat, $output_dateformat,
1906 $output_longdates) =
1907 selectrow_query($self, $dbh, $query,
1908 $self->{"language_id"}, $self->{"payment_id"});
1910 $self->{payment_terms} = $description_long if ($description_long);
1912 if ($output_dateformat) {
1913 foreach my $key (qw(netto_date skonto_date)) {
1915 $main::locale->reformat_date($myconfig, $self->{$key},
1921 if ($output_numberformat &&
1922 ($output_numberformat ne $myconfig->{"numberformat"})) {
1923 my $saved_numberformat = $myconfig->{"numberformat"};
1924 $myconfig->{"numberformat"} = $output_numberformat;
1925 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1926 $myconfig->{"numberformat"} = $saved_numberformat;
1930 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1931 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1932 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1933 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1934 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1935 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1936 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1938 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1940 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1942 $main::lxdebug->leave_sub();
1946 sub get_template_language {
1947 $main::lxdebug->enter_sub();
1949 my ($self, $myconfig) = @_;
1951 my $template_code = "";
1953 if ($self->{language_id}) {
1954 my $dbh = $self->get_standard_dbh($myconfig);
1955 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1956 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1959 $main::lxdebug->leave_sub();
1961 return $template_code;
1964 sub get_printer_code {
1965 $main::lxdebug->enter_sub();
1967 my ($self, $myconfig) = @_;
1969 my $template_code = "";
1971 if ($self->{printer_id}) {
1972 my $dbh = $self->get_standard_dbh($myconfig);
1973 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1974 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1977 $main::lxdebug->leave_sub();
1979 return $template_code;
1983 $main::lxdebug->enter_sub();
1985 my ($self, $myconfig) = @_;
1987 my $template_code = "";
1989 if ($self->{shipto_id}) {
1990 my $dbh = $self->get_standard_dbh($myconfig);
1991 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1992 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1993 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1996 $main::lxdebug->leave_sub();
2000 $main::lxdebug->enter_sub();
2002 my ($self, $dbh, $id, $module) = @_;
2007 foreach my $item (qw(name department_1 department_2 street zipcode city country
2008 contact cp_gender phone fax email)) {
2009 if ($self->{"shipto$item"}) {
2010 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2012 push(@values, $self->{"shipto${item}"});
2016 if ($self->{shipto_id}) {
2017 my $query = qq|UPDATE shipto set
2019 shiptodepartment_1 = ?,
2020 shiptodepartment_2 = ?,
2026 shiptocp_gender = ?,
2030 WHERE shipto_id = ?|;
2031 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2033 my $query = qq|SELECT * FROM shipto
2034 WHERE shiptoname = ? AND
2035 shiptodepartment_1 = ? AND
2036 shiptodepartment_2 = ? AND
2037 shiptostreet = ? AND
2038 shiptozipcode = ? AND
2040 shiptocountry = ? AND
2041 shiptocontact = ? AND
2042 shiptocp_gender = ? AND
2048 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2051 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2052 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2053 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2054 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2055 do_query($self, $dbh, $query, $id, @values, $module);
2060 $main::lxdebug->leave_sub();
2064 $main::lxdebug->enter_sub();
2066 my ($self, $dbh) = @_;
2068 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2070 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2071 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2072 $self->{"employee_id"} *= 1;
2074 $main::lxdebug->leave_sub();
2077 sub get_employee_data {
2078 $main::lxdebug->enter_sub();
2083 Common::check_params(\%params, qw(prefix));
2084 Common::check_params_x(\%params, qw(id));
2087 $main::lxdebug->leave_sub();
2091 my $myconfig = \%main::myconfig;
2092 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2094 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2097 my $user = User->new($login);
2098 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2100 $self->{$params{prefix} . '_login'} = $login;
2101 $self->{$params{prefix} . '_name'} ||= $login;
2104 $main::lxdebug->leave_sub();
2108 $main::lxdebug->enter_sub();
2110 my ($self, $myconfig, $reference_date) = @_;
2112 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2114 my $dbh = $self->get_standard_dbh($myconfig);
2115 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2116 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2118 $main::lxdebug->leave_sub();
2124 $main::lxdebug->enter_sub();
2126 my ($self, $dbh, $id, $key) = @_;
2128 $key = "all_contacts" unless ($key);
2132 $main::lxdebug->leave_sub();
2137 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2138 qq|FROM contacts | .
2139 qq|WHERE cp_cv_id = ? | .
2140 qq|ORDER BY lower(cp_name)|;
2142 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2144 $main::lxdebug->leave_sub();
2148 $main::lxdebug->enter_sub();
2150 my ($self, $dbh, $key) = @_;
2152 my ($all, $old_id, $where, @values);
2154 if (ref($key) eq "HASH") {
2157 $key = "ALL_PROJECTS";
2159 foreach my $p (keys(%{$params})) {
2161 $all = $params->{$p};
2162 } elsif ($p eq "old_id") {
2163 $old_id = $params->{$p};
2164 } elsif ($p eq "key") {
2165 $key = $params->{$p};
2171 $where = "WHERE active ";
2173 if (ref($old_id) eq "ARRAY") {
2174 my @ids = grep({ $_ } @{$old_id});
2176 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2177 push(@values, @ids);
2180 $where .= " OR (id = ?) ";
2181 push(@values, $old_id);
2187 qq|SELECT id, projectnumber, description, active | .
2190 qq|ORDER BY lower(projectnumber)|;
2192 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2194 $main::lxdebug->leave_sub();
2198 $main::lxdebug->enter_sub();
2200 my ($self, $dbh, $vc_id, $key) = @_;
2202 $key = "all_shipto" unless ($key);
2205 # get shipping addresses
2206 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2208 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2214 $main::lxdebug->leave_sub();
2218 $main::lxdebug->enter_sub();
2220 my ($self, $dbh, $key) = @_;
2222 $key = "all_printers" unless ($key);
2224 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2226 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2228 $main::lxdebug->leave_sub();
2232 $main::lxdebug->enter_sub();
2234 my ($self, $dbh, $params) = @_;
2237 $key = $params->{key};
2238 $key = "all_charts" unless ($key);
2240 my $transdate = quote_db_date($params->{transdate});
2243 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2245 qq|LEFT JOIN taxkeys tk ON | .
2246 qq|(tk.id = (SELECT id FROM taxkeys | .
2247 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2248 qq| ORDER BY startdate DESC LIMIT 1)) | .
2249 qq|ORDER BY c.accno|;
2251 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2253 $main::lxdebug->leave_sub();
2256 sub _get_taxcharts {
2257 $main::lxdebug->enter_sub();
2259 my ($self, $dbh, $params) = @_;
2261 my $key = "all_taxcharts";
2264 if (ref $params eq 'HASH') {
2265 $key = $params->{key} if ($params->{key});
2266 if ($params->{module} eq 'AR') {
2267 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2269 } elsif ($params->{module} eq 'AP') {
2270 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2277 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2279 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2281 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2283 $main::lxdebug->leave_sub();
2287 $main::lxdebug->enter_sub();
2289 my ($self, $dbh, $key) = @_;
2291 $key = "all_taxzones" unless ($key);
2293 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2295 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2297 $main::lxdebug->leave_sub();
2300 sub _get_employees {
2301 $main::lxdebug->enter_sub();
2303 my ($self, $dbh, $default_key, $key) = @_;
2305 $key = $default_key unless ($key);
2306 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2308 $main::lxdebug->leave_sub();
2311 sub _get_business_types {
2312 $main::lxdebug->enter_sub();
2314 my ($self, $dbh, $key) = @_;
2316 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2317 $options->{key} ||= "all_business_types";
2320 if (exists $options->{salesman}) {
2321 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2324 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2326 $main::lxdebug->leave_sub();
2329 sub _get_languages {
2330 $main::lxdebug->enter_sub();
2332 my ($self, $dbh, $key) = @_;
2334 $key = "all_languages" unless ($key);
2336 my $query = qq|SELECT * FROM language ORDER BY id|;
2338 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2340 $main::lxdebug->leave_sub();
2343 sub _get_dunning_configs {
2344 $main::lxdebug->enter_sub();
2346 my ($self, $dbh, $key) = @_;
2348 $key = "all_dunning_configs" unless ($key);
2350 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2352 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2354 $main::lxdebug->leave_sub();
2357 sub _get_currencies {
2358 $main::lxdebug->enter_sub();
2360 my ($self, $dbh, $key) = @_;
2362 $key = "all_currencies" unless ($key);
2364 my $query = qq|SELECT curr AS currency FROM defaults|;
2366 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2368 $main::lxdebug->leave_sub();
2372 $main::lxdebug->enter_sub();
2374 my ($self, $dbh, $key) = @_;
2376 $key = "all_payments" unless ($key);
2378 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2380 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2382 $main::lxdebug->leave_sub();
2385 sub _get_customers {
2386 $main::lxdebug->enter_sub();
2388 my ($self, $dbh, $key) = @_;
2390 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2391 $options->{key} ||= "all_customers";
2392 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2395 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2396 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2397 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2399 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2400 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2402 $main::lxdebug->leave_sub();
2406 $main::lxdebug->enter_sub();
2408 my ($self, $dbh, $key) = @_;
2410 $key = "all_vendors" unless ($key);
2412 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2414 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2416 $main::lxdebug->leave_sub();
2419 sub _get_departments {
2420 $main::lxdebug->enter_sub();
2422 my ($self, $dbh, $key) = @_;
2424 $key = "all_departments" unless ($key);
2426 my $query = qq|SELECT * FROM department ORDER BY description|;
2428 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2430 $main::lxdebug->leave_sub();
2433 sub _get_warehouses {
2434 $main::lxdebug->enter_sub();
2436 my ($self, $dbh, $param) = @_;
2438 my ($key, $bins_key);
2440 if ('' eq ref $param) {
2444 $key = $param->{key};
2445 $bins_key = $param->{bins};
2448 my $query = qq|SELECT w.* FROM warehouse w
2449 WHERE (NOT w.invalid) AND
2450 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2451 ORDER BY w.sortkey|;
2453 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2456 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2457 my $sth = prepare_query($self, $dbh, $query);
2459 foreach my $warehouse (@{ $self->{$key} }) {
2460 do_statement($self, $sth, $query, $warehouse->{id});
2461 $warehouse->{$bins_key} = [];
2463 while (my $ref = $sth->fetchrow_hashref()) {
2464 push @{ $warehouse->{$bins_key} }, $ref;
2470 $main::lxdebug->leave_sub();
2474 $main::lxdebug->enter_sub();
2476 my ($self, $dbh, $table, $key, $sortkey) = @_;
2478 my $query = qq|SELECT * FROM $table|;
2479 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2481 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2483 $main::lxdebug->leave_sub();
2487 # $main::lxdebug->enter_sub();
2489 # my ($self, $dbh, $key) = @_;
2491 # $key ||= "all_groups";
2493 # my $groups = $main::auth->read_groups();
2495 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2497 # $main::lxdebug->leave_sub();
2501 $main::lxdebug->enter_sub();
2506 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2507 my ($sth, $query, $ref);
2509 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2510 my $vc_id = $self->{"${vc}_id"};
2512 if ($params{"contacts"}) {
2513 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2516 if ($params{"shipto"}) {
2517 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2520 if ($params{"projects"} || $params{"all_projects"}) {
2521 $self->_get_projects($dbh, $params{"all_projects"} ?
2522 $params{"all_projects"} : $params{"projects"},
2523 $params{"all_projects"} ? 1 : 0);
2526 if ($params{"printers"}) {
2527 $self->_get_printers($dbh, $params{"printers"});
2530 if ($params{"languages"}) {
2531 $self->_get_languages($dbh, $params{"languages"});
2534 if ($params{"charts"}) {
2535 $self->_get_charts($dbh, $params{"charts"});
2538 if ($params{"taxcharts"}) {
2539 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2542 if ($params{"taxzones"}) {
2543 $self->_get_taxzones($dbh, $params{"taxzones"});
2546 if ($params{"employees"}) {
2547 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2550 if ($params{"salesmen"}) {
2551 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2554 if ($params{"business_types"}) {
2555 $self->_get_business_types($dbh, $params{"business_types"});
2558 if ($params{"dunning_configs"}) {
2559 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2562 if($params{"currencies"}) {
2563 $self->_get_currencies($dbh, $params{"currencies"});
2566 if($params{"customers"}) {
2567 $self->_get_customers($dbh, $params{"customers"});
2570 if($params{"vendors"}) {
2571 if (ref $params{"vendors"} eq 'HASH') {
2572 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2574 $self->_get_vendors($dbh, $params{"vendors"});
2578 if($params{"payments"}) {
2579 $self->_get_payments($dbh, $params{"payments"});
2582 if($params{"departments"}) {
2583 $self->_get_departments($dbh, $params{"departments"});
2586 if ($params{price_factors}) {
2587 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2590 if ($params{warehouses}) {
2591 $self->_get_warehouses($dbh, $params{warehouses});
2594 # if ($params{groups}) {
2595 # $self->_get_groups($dbh, $params{groups});
2598 if ($params{partsgroup}) {
2599 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2602 $main::lxdebug->leave_sub();
2605 # this sub gets the id and name from $table
2607 $main::lxdebug->enter_sub();
2609 my ($self, $myconfig, $table) = @_;
2611 # connect to database
2612 my $dbh = $self->get_standard_dbh($myconfig);
2614 $table = $table eq "customer" ? "customer" : "vendor";
2615 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2617 my ($query, @values);
2619 if (!$self->{openinvoices}) {
2621 if ($self->{customernumber} ne "") {
2622 $where = qq|(vc.customernumber ILIKE ?)|;
2623 push(@values, '%' . $self->{customernumber} . '%');
2625 $where = qq|(vc.name ILIKE ?)|;
2626 push(@values, '%' . $self->{$table} . '%');
2630 qq~SELECT vc.id, vc.name,
2631 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2633 WHERE $where AND (NOT vc.obsolete)
2637 qq~SELECT DISTINCT vc.id, vc.name,
2638 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2640 JOIN $table vc ON (a.${table}_id = vc.id)
2641 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2643 push(@values, '%' . $self->{$table} . '%');
2646 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2648 $main::lxdebug->leave_sub();
2650 return scalar(@{ $self->{name_list} });
2653 # the selection sub is used in the AR, AP, IS, IR and OE module
2656 $main::lxdebug->enter_sub();
2658 my ($self, $myconfig, $table, $module) = @_;
2661 my $dbh = $self->get_standard_dbh;
2663 $table = $table eq "customer" ? "customer" : "vendor";
2665 my $query = qq|SELECT count(*) FROM $table|;
2666 my ($count) = selectrow_query($self, $dbh, $query);
2668 # build selection list
2669 if ($count <= $myconfig->{vclimit}) {
2670 $query = qq|SELECT id, name, salesman_id
2671 FROM $table WHERE NOT obsolete
2673 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2677 $self->get_employee($dbh);
2679 # setup sales contacts
2680 $query = qq|SELECT e.id, e.name
2682 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2683 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2686 push(@{ $self->{all_employees} },
2687 { id => $self->{employee_id},
2688 name => $self->{employee} });
2690 # sort the whole thing
2691 @{ $self->{all_employees} } =
2692 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2694 if ($module eq 'AR') {
2696 # prepare query for departments
2697 $query = qq|SELECT id, description
2700 ORDER BY description|;
2703 $query = qq|SELECT id, description
2705 ORDER BY description|;
2708 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2711 $query = qq|SELECT id, description
2715 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2718 $query = qq|SELECT printer_description, id
2720 ORDER BY printer_description|;
2722 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2725 $query = qq|SELECT id, description
2729 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2731 $main::lxdebug->leave_sub();
2734 sub language_payment {
2735 $main::lxdebug->enter_sub();
2737 my ($self, $myconfig) = @_;
2739 my $dbh = $self->get_standard_dbh($myconfig);
2741 my $query = qq|SELECT id, description
2745 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2748 $query = qq|SELECT printer_description, id
2750 ORDER BY printer_description|;
2752 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2755 $query = qq|SELECT id, description
2759 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2761 # get buchungsgruppen
2762 $query = qq|SELECT id, description
2763 FROM buchungsgruppen|;
2765 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2767 $main::lxdebug->leave_sub();
2770 # this is only used for reports
2771 sub all_departments {
2772 $main::lxdebug->enter_sub();
2774 my ($self, $myconfig, $table) = @_;
2776 my $dbh = $self->get_standard_dbh($myconfig);
2779 if ($table eq 'customer') {
2780 $where = "WHERE role = 'P' ";
2783 my $query = qq|SELECT id, description
2786 ORDER BY description|;
2787 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2789 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2791 $main::lxdebug->leave_sub();
2795 $main::lxdebug->enter_sub();
2797 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2800 if ($table eq "customer") {
2809 $self->all_vc($myconfig, $table, $module);
2811 # get last customers or vendors
2812 my ($query, $sth, $ref);
2814 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2819 my $transdate = "current_date";
2820 if ($self->{transdate}) {
2821 $transdate = $dbh->quote($self->{transdate});
2824 # now get the account numbers
2825 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2826 FROM chart c, taxkeys tk
2827 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2828 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2831 $sth = $dbh->prepare($query);
2833 do_statement($self, $sth, $query, '%' . $module . '%');
2835 $self->{accounts} = "";
2836 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2838 foreach my $key (split(/:/, $ref->{link})) {
2839 if ($key =~ /\Q$module\E/) {
2841 # cross reference for keys
2842 $xkeyref{ $ref->{accno} } = $key;
2844 push @{ $self->{"${module}_links"}{$key} },
2845 { accno => $ref->{accno},
2846 description => $ref->{description},
2847 taxkey => $ref->{taxkey_id},
2848 tax_id => $ref->{tax_id} };
2850 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2856 # get taxkeys and description
2857 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2858 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2860 if (($module eq "AP") || ($module eq "AR")) {
2861 # get tax rates and description
2862 $query = qq|SELECT * FROM tax|;
2863 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2869 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2870 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2871 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2872 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2874 d.description AS department,
2877 JOIN $table c ON (a.${table}_id = c.id)
2878 LEFT JOIN employee e ON (e.id = a.employee_id)
2879 LEFT JOIN department d ON (d.id = a.department_id)
2881 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2883 foreach my $key (keys %$ref) {
2884 $self->{$key} = $ref->{$key};
2887 my $transdate = "current_date";
2888 if ($self->{transdate}) {
2889 $transdate = $dbh->quote($self->{transdate});
2892 # now get the account numbers
2893 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2895 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2897 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2898 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2901 $sth = $dbh->prepare($query);
2902 do_statement($self, $sth, $query, "%$module%");
2904 $self->{accounts} = "";
2905 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2907 foreach my $key (split(/:/, $ref->{link})) {
2908 if ($key =~ /\Q$module\E/) {
2910 # cross reference for keys
2911 $xkeyref{ $ref->{accno} } = $key;
2913 push @{ $self->{"${module}_links"}{$key} },
2914 { accno => $ref->{accno},
2915 description => $ref->{description},
2916 taxkey => $ref->{taxkey_id},
2917 tax_id => $ref->{tax_id} };
2919 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2925 # get amounts from individual entries
2928 c.accno, c.description,
2929 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2933 LEFT JOIN chart c ON (c.id = a.chart_id)
2934 LEFT JOIN project p ON (p.id = a.project_id)
2935 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2936 WHERE (tk.taxkey_id=a.taxkey) AND
2937 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2938 THEN tk.chart_id = a.chart_id
2941 OR (c.link='%tax%')) AND
2942 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2943 WHERE a.trans_id = ?
2944 AND a.fx_transaction = '0'
2945 ORDER BY a.acc_trans_id, a.transdate|;
2946 $sth = $dbh->prepare($query);
2947 do_statement($self, $sth, $query, $self->{id});
2949 # get exchangerate for currency
2950 $self->{exchangerate} =
2951 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2954 # store amounts in {acc_trans}{$key} for multiple accounts
2955 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2956 $ref->{exchangerate} =
2957 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2958 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2961 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2962 $ref->{amount} *= -1;
2964 $ref->{index} = $index;
2966 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2972 d.curr AS currencies, d.closedto, d.revtrans,
2973 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2974 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2976 $ref = selectfirst_hashref_query($self, $dbh, $query);
2977 map { $self->{$_} = $ref->{$_} } keys %$ref;
2984 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2985 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2986 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2988 $ref = selectfirst_hashref_query($self, $dbh, $query);
2989 map { $self->{$_} = $ref->{$_} } keys %$ref;
2991 if ($self->{"$self->{vc}_id"}) {
2993 # only setup currency
2994 ($self->{currency}) = split(/:/, $self->{currencies});
2998 $self->lastname_used($dbh, $myconfig, $table, $module);
3000 # get exchangerate for currency
3001 $self->{exchangerate} =
3002 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3008 $main::lxdebug->leave_sub();
3012 $main::lxdebug->enter_sub();
3014 my ($self, $dbh, $myconfig, $table, $module) = @_;
3018 $table = $table eq "customer" ? "customer" : "vendor";
3019 my %column_map = ("a.curr" => "currency",
3020 "a.${table}_id" => "${table}_id",
3021 "a.department_id" => "department_id",
3022 "d.description" => "department",
3023 "ct.name" => $table,
3024 "current_date + ct.terms" => "duedate",
3027 if ($self->{type} =~ /delivery_order/) {
3028 $arap = 'delivery_orders';
3029 delete $column_map{"a.curr"};
3031 } elsif ($self->{type} =~ /_order/) {
3033 $where = "quotation = '0'";
3035 } elsif ($self->{type} =~ /_quotation/) {
3037 $where = "quotation = '1'";
3039 } elsif ($table eq 'customer') {
3047 $where = "($where) AND" if ($where);
3048 my $query = qq|SELECT MAX(id) FROM $arap
3049 WHERE $where ${table}_id > 0|;
3050 my ($trans_id) = selectrow_query($self, $dbh, $query);
3053 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3054 $query = qq|SELECT $column_spec
3056 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3057 LEFT JOIN department d ON (a.department_id = d.id)
3059 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3061 map { $self->{$_} = $ref->{$_} } values %column_map;
3063 $main::lxdebug->leave_sub();
3067 $main::lxdebug->enter_sub();
3070 my $myconfig = shift || \%::myconfig;
3071 my ($thisdate, $days) = @_;
3073 my $dbh = $self->get_standard_dbh($myconfig);
3078 my $dateformat = $myconfig->{dateformat};
3079 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3080 $thisdate = $dbh->quote($thisdate);
3081 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3083 $query = qq|SELECT current_date AS thisdate|;
3086 ($thisdate) = selectrow_query($self, $dbh, $query);
3088 $main::lxdebug->leave_sub();
3094 $main::lxdebug->enter_sub();
3096 my ($self, $string) = @_;
3098 if ($string !~ /%/) {
3099 $string = "%$string%";
3102 $string =~ s/\'/\'\'/g;
3104 $main::lxdebug->leave_sub();
3110 $main::lxdebug->enter_sub();
3112 my ($self, $flds, $new, $count, $numrows) = @_;
3116 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3121 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3123 my $j = $item->{ndx} - 1;
3124 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3128 for $i ($count + 1 .. $numrows) {
3129 map { delete $self->{"${_}_$i"} } @{$flds};
3132 $main::lxdebug->leave_sub();
3136 $main::lxdebug->enter_sub();
3138 my ($self, $myconfig) = @_;
3142 my $dbh = $self->dbconnect_noauto($myconfig);
3144 my $query = qq|DELETE FROM status
3145 WHERE (formname = ?) AND (trans_id = ?)|;
3146 my $sth = prepare_query($self, $dbh, $query);
3148 if ($self->{formname} =~ /(check|receipt)/) {
3149 for $i (1 .. $self->{rowcount}) {
3150 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3153 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3157 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3158 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3160 my %queued = split / /, $self->{queued};
3163 if ($self->{formname} =~ /(check|receipt)/) {
3165 # this is a check or receipt, add one entry for each lineitem
3166 my ($accno) = split /--/, $self->{account};
3167 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3168 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3169 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3170 $sth = prepare_query($self, $dbh, $query);
3172 for $i (1 .. $self->{rowcount}) {
3173 if ($self->{"checked_$i"}) {
3174 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3180 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3181 VALUES (?, ?, ?, ?, ?)|;
3182 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3183 $queued{$self->{formname}}, $self->{formname});
3189 $main::lxdebug->leave_sub();
3193 $main::lxdebug->enter_sub();
3195 my ($self, $dbh) = @_;
3197 my ($query, $printed, $emailed);
3199 my $formnames = $self->{printed};
3200 my $emailforms = $self->{emailed};
3202 $query = qq|DELETE FROM status
3203 WHERE (formname = ?) AND (trans_id = ?)|;
3204 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3206 # this only applies to the forms
3207 # checks and receipts are posted when printed or queued
3209 if ($self->{queued}) {
3210 my %queued = split / /, $self->{queued};
3212 foreach my $formname (keys %queued) {
3213 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3214 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3216 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3217 VALUES (?, ?, ?, ?, ?)|;
3218 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3220 $formnames =~ s/\Q$self->{formname}\E//;
3221 $emailforms =~ s/\Q$self->{formname}\E//;
3226 # save printed, emailed info
3227 $formnames =~ s/^ +//g;
3228 $emailforms =~ s/^ +//g;
3231 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3232 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3234 foreach my $formname (keys %status) {
3235 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3236 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3238 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3239 VALUES (?, ?, ?, ?)|;
3240 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3243 $main::lxdebug->leave_sub();
3247 # $main::locale->text('SAVED')
3248 # $main::locale->text('DELETED')
3249 # $main::locale->text('ADDED')
3250 # $main::locale->text('PAYMENT POSTED')
3251 # $main::locale->text('POSTED')
3252 # $main::locale->text('POSTED AS NEW')
3253 # $main::locale->text('ELSE')
3254 # $main::locale->text('SAVED FOR DUNNING')
3255 # $main::locale->text('DUNNING STARTED')
3256 # $main::locale->text('PRINTED')
3257 # $main::locale->text('MAILED')
3258 # $main::locale->text('SCREENED')
3259 # $main::locale->text('CANCELED')
3260 # $main::locale->text('invoice')
3261 # $main::locale->text('proforma')
3262 # $main::locale->text('sales_order')
3263 # $main::locale->text('pick_list')
3264 # $main::locale->text('purchase_order')
3265 # $main::locale->text('bin_list')
3266 # $main::locale->text('sales_quotation')
3267 # $main::locale->text('request_quotation')
3270 $main::lxdebug->enter_sub();
3273 my $dbh = shift || $self->get_standard_dbh;
3275 if(!exists $self->{employee_id}) {
3276 &get_employee($self, $dbh);
3280 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3281 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3282 my @values = (conv_i($self->{id}), $self->{login},
3283 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3284 do_query($self, $dbh, $query, @values);
3288 $main::lxdebug->leave_sub();
3292 $main::lxdebug->enter_sub();
3294 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3295 my ($orderBy, $desc) = split(/\-\-/, $order);
3296 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3299 if ($trans_id ne "") {
3301 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 | .
3302 qq|FROM history_erp h | .
3303 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3304 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3307 my $sth = $dbh->prepare($query) || $self->dberror($query);
3309 $sth->execute() || $self->dberror("$query");
3311 while(my $hash_ref = $sth->fetchrow_hashref()) {
3312 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3313 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3314 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3315 $tempArray[$i++] = $hash_ref;
3317 $main::lxdebug->leave_sub() and return \@tempArray
3318 if ($i > 0 && $tempArray[0] ne "");
3320 $main::lxdebug->leave_sub();
3324 sub update_defaults {
3325 $main::lxdebug->enter_sub();
3327 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3330 if ($provided_dbh) {
3331 $dbh = $provided_dbh;
3333 $dbh = $self->dbconnect_noauto($myconfig);
3335 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3336 my $sth = $dbh->prepare($query);
3338 $sth->execute || $self->dberror($query);
3339 my ($var) = $sth->fetchrow_array;
3342 if ($var =~ m/\d+$/) {
3343 my $new_var = (substr $var, $-[0]) * 1 + 1;
3344 my $len_diff = length($var) - $-[0] - length($new_var);
3345 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3351 $query = qq|UPDATE defaults SET $fld = ?|;
3352 do_query($self, $dbh, $query, $var);
3354 if (!$provided_dbh) {
3359 $main::lxdebug->leave_sub();
3364 sub update_business {
3365 $main::lxdebug->enter_sub();
3367 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3370 if ($provided_dbh) {
3371 $dbh = $provided_dbh;
3373 $dbh = $self->dbconnect_noauto($myconfig);
3376 qq|SELECT customernumberinit FROM business
3377 WHERE id = ? FOR UPDATE|;
3378 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3380 return undef unless $var;
3382 if ($var =~ m/\d+$/) {
3383 my $new_var = (substr $var, $-[0]) * 1 + 1;
3384 my $len_diff = length($var) - $-[0] - length($new_var);
3385 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3391 $query = qq|UPDATE business
3392 SET customernumberinit = ?
3394 do_query($self, $dbh, $query, $var, $business_id);
3396 if (!$provided_dbh) {
3401 $main::lxdebug->leave_sub();
3406 sub get_partsgroup {
3407 $main::lxdebug->enter_sub();
3409 my ($self, $myconfig, $p) = @_;
3410 my $target = $p->{target} || 'all_partsgroup';
3412 my $dbh = $self->get_standard_dbh($myconfig);
3414 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3416 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3419 if ($p->{searchitems} eq 'part') {
3420 $query .= qq|WHERE p.inventory_accno_id > 0|;
3422 if ($p->{searchitems} eq 'service') {
3423 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3425 if ($p->{searchitems} eq 'assembly') {
3426 $query .= qq|WHERE p.assembly = '1'|;
3428 if ($p->{searchitems} eq 'labor') {
3429 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3432 $query .= qq|ORDER BY partsgroup|;
3435 $query = qq|SELECT id, partsgroup FROM partsgroup
3436 ORDER BY partsgroup|;
3439 if ($p->{language_code}) {
3440 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3441 t.description AS translation
3443 JOIN parts p ON (p.partsgroup_id = pg.id)
3444 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3445 ORDER BY translation|;
3446 @values = ($p->{language_code});
3449 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3451 $main::lxdebug->leave_sub();
3454 sub get_pricegroup {
3455 $main::lxdebug->enter_sub();
3457 my ($self, $myconfig, $p) = @_;
3459 my $dbh = $self->get_standard_dbh($myconfig);
3461 my $query = qq|SELECT p.id, p.pricegroup
3464 $query .= qq| ORDER BY pricegroup|;
3467 $query = qq|SELECT id, pricegroup FROM pricegroup
3468 ORDER BY pricegroup|;
3471 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3473 $main::lxdebug->leave_sub();
3477 # usage $form->all_years($myconfig, [$dbh])
3478 # return list of all years where bookings found
3481 $main::lxdebug->enter_sub();
3483 my ($self, $myconfig, $dbh) = @_;
3485 $dbh ||= $self->get_standard_dbh($myconfig);
3488 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3489 (SELECT MAX(transdate) FROM acc_trans)|;
3490 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3492 if ($myconfig->{dateformat} =~ /^yy/) {
3493 ($startdate) = split /\W/, $startdate;
3494 ($enddate) = split /\W/, $enddate;
3496 (@_) = split /\W/, $startdate;
3498 (@_) = split /\W/, $enddate;
3503 $startdate = substr($startdate,0,4);
3504 $enddate = substr($enddate,0,4);
3506 while ($enddate >= $startdate) {
3507 push @all_years, $enddate--;
3512 $main::lxdebug->leave_sub();
3516 $main::lxdebug->enter_sub();
3520 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3522 $main::lxdebug->leave_sub();
3526 $main::lxdebug->enter_sub();
3531 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3533 $main::lxdebug->leave_sub();
3536 sub prepare_for_printing {
3539 $self->{templates} ||= $::myconfig{templates};
3540 $self->{formname} ||= $self->{type};
3541 $self->{media} ||= 'email';
3543 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3545 # set shipto from billto unless set
3546 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3547 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3548 $self->{shiptoname} = $::myconfig{company};
3549 $self->{shiptostreet} = $::myconfig{address};
3552 my $language = $self->{language} ? '_' . $self->{language} : '';
3554 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3555 if ($self->{language_id}) {
3556 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3558 $output_dateformat = $::myconfig{dateformat};
3559 $output_numberformat = $::myconfig{numberformat};
3560 $output_longdates = 1;
3563 # Retrieve accounts for tax calculation.
3564 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3566 if ($self->{type} =~ /_delivery_order$/) {
3567 DO->order_details();
3568 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3569 OE->order_details(\%::myconfig, $self);
3571 IS->invoice_details(\%::myconfig, $self, $::locale);
3574 # Chose extension & set source file name
3575 my $extension = 'html';
3576 if ($self->{format} eq 'postscript') {
3577 $self->{postscript} = 1;
3579 } elsif ($self->{"format"} =~ /pdf/) {
3581 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3582 } elsif ($self->{"format"} =~ /opendocument/) {
3583 $self->{opendocument} = 1;
3585 } elsif ($self->{"format"} =~ /excel/) {
3590 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3591 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3592 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3595 $self->format_dates($output_dateformat, $output_longdates,
3596 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3597 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3598 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3600 $self->reformat_numbers($output_numberformat, 2,
3601 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3602 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3604 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3606 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3608 if (scalar @{ $cvar_date_fields }) {
3609 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3612 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3613 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3620 my ($self, $dateformat, $longformat, @indices) = @_;
3622 $dateformat ||= $::myconfig{dateformat};
3624 foreach my $idx (@indices) {
3625 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3626 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3627 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3631 next unless defined $self->{$idx};
3633 if (!ref($self->{$idx})) {
3634 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3636 } elsif (ref($self->{$idx}) eq "ARRAY") {
3637 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3638 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3644 sub reformat_numbers {
3645 my ($self, $numberformat, $places, @indices) = @_;
3647 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3649 foreach my $idx (@indices) {
3650 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3651 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3652 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3656 next unless defined $self->{$idx};
3658 if (!ref($self->{$idx})) {
3659 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3661 } elsif (ref($self->{$idx}) eq "ARRAY") {
3662 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3663 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3668 my $saved_numberformat = $::myconfig{numberformat};
3669 $::myconfig{numberformat} = $numberformat;
3671 foreach my $idx (@indices) {
3672 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3673 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3674 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3678 next unless defined $self->{$idx};
3680 if (!ref($self->{$idx})) {
3681 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3683 } elsif (ref($self->{$idx}) eq "ARRAY") {
3684 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3685 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3690 $::myconfig{numberformat} = $saved_numberformat;
3699 SL::Form.pm - main data object.
3703 This is the main data object of Lx-Office.
3704 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3705 Points of interest for a beginner are:
3707 - $form->error - renders a generic error in html. accepts an error message
3708 - $form->get_standard_dbh - returns a database connection for the
3710 =head1 SPECIAL FUNCTIONS
3712 =head2 C<_store_value()>
3714 parses a complex var name, and stores it in the form.
3717 $form->_store_value($key, $value);
3719 keys must start with a string, and can contain various tokens.
3720 supported key structures are:
3723 simple key strings work as expected
3728 separating two keys by a dot (.) will result in a hash lookup for the inner value
3729 this is similar to the behaviour of java and templating mechanisms.
3731 filter.description => $form->{filter}->{description}
3733 3. array+hashref access
3735 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3736 using [+] instead of [] will force a new array index. this is useful for recurring
3737 data structures like part lists. put a [+] into the first varname, and use [] on the
3740 repeating these names in your template:
3743 invoice.items[].parts_id
3747 $form->{invoice}->{items}->[
3761 using brackets at the end of a name will result in a pure array to be created.
3762 note that you mustn't use [+], which is reserved for array+hash access and will
3763 result in undefined behaviour in array context.
3765 filter.status[] => $form->{status}->[ val1, val2, ... ]
3767 =head2 C<update_business> PARAMS
3770 \%config, - config hashref
3771 $business_id, - business id
3772 $dbh - optional database handle
3774 handles business (thats customer/vendor types) sequences.
3776 special behaviour for empty strings in customerinitnumber field:
3777 will in this case not increase the value, and return undef.
3779 =head2 C<redirect_header> $url
3781 Generates a HTTP redirection header for the new C<$url>. Constructs an
3782 absolute URL including scheme, host name and port. If C<$url> is a
3783 relative URL then it is considered relative to Lx-Office base URL.
3785 This function C<die>s if headers have already been created with
3786 C<$::form-E<gt>header>.
3790 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3791 print $::form->redirect_header('http://www.lx-office.org/');
3795 Generates a general purpose http/html header and includes most of the scripts
3796 ans stylesheets needed.
3798 Only one header will be generated. If the method was already called in this
3799 request it will not output anything and return undef. Also if no
3800 HTTP_USER_AGENT is found, no header is generated.
3802 Although header does not accept parameters itself, it will honor special
3803 hashkeys of its Form instance:
3811 If one of these is set, a http-equiv refresh is generated. Missing parameters
3812 default to 3 seconds and the refering url.
3818 If these are arrayrefs the contents will be inlined into the header.
3822 If true, a css snippet will be generated that sets the page in landscape mode.
3826 Used to override the default favicon.
3830 A html page title will be generated from this