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 = $main::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;
405 $main::lxdebug->leave_sub(2);
411 $main::lxdebug->enter_sub();
412 my ($self, $str) = @_;
414 if ($str && !ref($str)) {
415 $str =~ s/\"/"/g;
418 $main::lxdebug->leave_sub();
424 $main::lxdebug->enter_sub();
425 my ($self, $str) = @_;
427 if ($str && !ref($str)) {
428 $str =~ s/"/\"/g;
431 $main::lxdebug->leave_sub();
437 $main::lxdebug->enter_sub();
441 map({ print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_);
443 for (sort keys %$self) {
444 next if (($_ eq "header") || (ref($self->{$_}) ne ""));
445 print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n");
448 $main::lxdebug->leave_sub();
452 my ($self, $code) = @_;
453 local $self->{__ERROR_HANDLER} = sub { die({ error => $_[0] }) };
458 $main::lxdebug->enter_sub();
460 $main::lxdebug->show_backtrace();
462 my ($self, $msg) = @_;
464 if ($self->{__ERROR_HANDLER}) {
465 $self->{__ERROR_HANDLER}->($msg);
467 } elsif ($ENV{HTTP_USER_AGENT}) {
469 $self->show_generic_error($msg);
472 print STDERR "Error: $msg\n";
476 $main::lxdebug->leave_sub();
480 $main::lxdebug->enter_sub();
482 my ($self, $msg) = @_;
484 if ($ENV{HTTP_USER_AGENT}) {
487 if (!$self->{header}) {
493 <p class="message_ok"><b>$msg</b></p>
495 <script type="text/javascript">
497 // If JavaScript is enabled, the whole thing will be reloaded.
498 // The reason is: When one changes his menu setup (HTML / XUL / CSS ...)
499 // it now loads the correct code into the browser instead of do nothing.
500 setTimeout("top.frames.location.href='login.pl'",500);
509 if ($self->{info_function}) {
510 &{ $self->{info_function} }($msg);
516 $main::lxdebug->leave_sub();
519 # calculates the number of rows in a textarea based on the content and column number
520 # can be capped with maxrows
522 $main::lxdebug->enter_sub();
523 my ($self, $str, $cols, $maxrows, $minrows) = @_;
527 my $rows = sum map { int((length() - 2) / $cols) + 1 } split /\r/, $str;
530 $main::lxdebug->leave_sub();
532 return max(min($rows, $maxrows), $minrows);
536 $main::lxdebug->enter_sub();
538 my ($self, $msg) = @_;
540 $self->error("$msg\n" . $DBI::errstr);
542 $main::lxdebug->leave_sub();
546 $main::lxdebug->enter_sub();
548 my ($self, $name, $msg) = @_;
551 foreach my $part (split m/\./, $name) {
552 if (!$curr->{$part} || ($curr->{$part} =~ /^\s*$/)) {
555 $curr = $curr->{$part};
558 $main::lxdebug->leave_sub();
561 sub _get_request_uri {
564 return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
566 my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http';
567 my $port = $ENV{SERVER_PORT} || '';
568 $port = undef if (($scheme eq 'http' ) && ($port == 80))
569 || (($scheme eq 'https') && ($port == 443));
571 my $uri = URI->new("${scheme}://");
572 $uri->scheme($scheme);
574 $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
575 $uri->path_query($ENV{REQUEST_URI});
581 sub _add_to_request_uri {
584 my $relative_new_path = shift;
585 my $request_uri = shift || $self->_get_request_uri;
586 my $relative_new_uri = URI->new($relative_new_path);
587 my @request_segments = $request_uri->path_segments;
589 my $new_uri = $request_uri->clone;
590 $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments);
595 sub create_http_response {
596 $main::lxdebug->enter_sub();
601 my $cgi = $main::cgi;
602 $cgi ||= CGI->new('');
605 if (defined $main::auth) {
606 my $uri = $self->_get_request_uri;
607 my @segments = $uri->path_segments;
609 $uri->path_segments(@segments);
611 my $session_cookie_value = $main::auth->get_session_id();
613 if ($session_cookie_value) {
614 $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
615 '-value' => $session_cookie_value,
616 '-path' => $uri->path,
617 '-secure' => $ENV{HTTPS});
621 my %cgi_params = ('-type' => $params{content_type});
622 $cgi_params{'-charset'} = $params{charset} if ($params{charset});
623 $cgi_params{'-cookie'} = $session_cookie if ($session_cookie);
625 my $output = $cgi->header(%cgi_params);
627 $main::lxdebug->leave_sub();
634 $::lxdebug->enter_sub;
636 # extra code is currently only used by menuv3 and menuv4 to set their css.
637 # it is strongly deprecated, and will be changed in a future version.
638 my ($self, $extra_code) = @_;
639 my $db_charset = $::dbcharset || Common::DEFAULT_CHARSET;
642 $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
644 $self->{favicon} ||= "favicon.ico";
645 $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title};
648 if ($self->{refresh_url} || $self->{refresh_time}) {
649 my $refresh_time = $self->{refresh_time} || 3;
650 my $refresh_url = $self->{refresh_url} || $ENV{REFERER};
651 push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
654 push @header, "<link rel='stylesheet' href='css/$_' type='text/css' title='Lx-Office stylesheet'>"
655 for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets};
657 push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
658 push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
659 push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
660 '<script type="text/javascript" src="js/common.js"></script>',
661 '<style type="text/css">@import url(js/jscalendar/calendar-win2k-1.css);</style>',
662 '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
663 '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
664 '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
665 '<script type="text/javascript" src="js/part_selection.js"></script>';
666 push @header, $self->{javascript} if $self->{javascript};
667 push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
668 push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
669 push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
670 join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title};
672 # if there is a title, we put some JavaScript in to the page, wich writes a
673 # meaningful title-tag for our frameset.
675 if ($self->{title}) {
677 <script type="text/javascript">
679 // Write a meaningful title-tag for our frameset.
680 top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
686 print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
687 print "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01//EN' 'http://www.w3.org/TR/html4/strict.dtd'>\n"
688 if $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/; # Other browsers may choke on menu scripts with DOCTYPE.
692 <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
693 <title>$self->{titlebar}</title>
695 print " $_\n" for @header;
697 <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css" />
698 <meta name="robots" content="noindex,nofollow" />
699 <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
700 <script type="text/javascript" src="js/tabcontent.js">
702 /***********************************************
703 * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
704 * This notice MUST stay intact for legal use
705 * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
706 ***********************************************/
715 $::lxdebug->leave_sub;
718 sub ajax_response_header {
719 $main::lxdebug->enter_sub();
723 my $db_charset = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
724 my $cgi = $main::cgi || CGI->new('');
725 my $output = $cgi->header('-charset' => $db_charset);
727 $main::lxdebug->leave_sub();
732 sub redirect_header {
736 my $base_uri = $self->_get_request_uri;
737 my $new_uri = URI->new_abs($new_url, $base_uri);
739 die "Headers already sent" if $::self->{header};
742 my $cgi = $main::cgi || CGI->new('');
743 return $cgi->redirect($new_uri);
746 sub set_standard_title {
747 $::lxdebug->enter_sub;
750 $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
751 $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
752 $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
754 $::lxdebug->leave_sub;
757 sub _prepare_html_template {
758 $main::lxdebug->enter_sub();
760 my ($self, $file, $additional_params) = @_;
763 if (!%::myconfig || !$::myconfig{"countrycode"}) {
764 $language = $main::language;
766 $language = $main::myconfig{"countrycode"};
768 $language = "de" unless ($language);
770 if (-f "templates/webpages/${file}.html") {
771 if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
772 my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
773 "Please re-run 'locales.pl' in 'locale/${language}'.";
774 print(qq|<pre>$info</pre>|);
778 $file = "templates/webpages/${file}.html";
781 my $info = "Web page template '${file}' not found.\n";
782 print qq|<pre>$info</pre>|;
786 if ($self->{"DEBUG"}) {
787 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
790 if ($additional_params->{"DEBUG"}) {
791 $additional_params->{"DEBUG"} =
792 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
795 if (%main::myconfig) {
796 $::myconfig{jsc_dateformat} = apply {
800 } $::myconfig{"dateformat"};
801 $additional_params->{"myconfig"} ||= \%::myconfig;
802 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
805 $additional_params->{"conf_dbcharset"} = $::dbcharset;
806 $additional_params->{"conf_webdav"} = $::webdav;
807 $additional_params->{"conf_lizenzen"} = $::lizenzen;
808 $additional_params->{"conf_latex_templates"} = $::latex;
809 $additional_params->{"conf_opendocument_templates"} = $::opendocument_templates;
810 $additional_params->{"conf_vertreter"} = $::vertreter;
811 $additional_params->{"conf_show_best_before"} = $::show_best_before;
812 $additional_params->{"conf_parts_image_css"} = $::parts_image_css;
813 $additional_params->{"conf_parts_listing_images"} = $::parts_listing_images;
814 $additional_params->{"conf_parts_show_image"} = $::parts_show_image;
816 if (%main::debug_options) {
817 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
820 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
821 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
822 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
826 $main::lxdebug->leave_sub();
831 sub parse_html_template {
832 $main::lxdebug->enter_sub();
834 my ($self, $file, $additional_params) = @_;
836 $additional_params ||= { };
838 my $real_file = $self->_prepare_html_template($file, $additional_params);
839 my $template = $self->template || $self->init_template;
841 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
844 $template->process($real_file, $additional_params, \$output) || die $template->error;
846 $main::lxdebug->leave_sub();
854 return if $self->template;
856 return $self->template(Template->new({
861 'PLUGIN_BASE' => 'SL::Template::Plugin',
862 'INCLUDE_PATH' => '.:templates/webpages',
863 'COMPILE_EXT' => '.tcc',
864 'COMPILE_DIR' => $::userspath . '/templates-cache',
870 $self->{template_object} = shift if @_;
871 return $self->{template_object};
874 sub show_generic_error {
875 $main::lxdebug->enter_sub();
877 my ($self, $error, %params) = @_;
879 if ($self->{__ERROR_HANDLER}) {
880 $self->{__ERROR_HANDLER}->($error);
881 $main::lxdebug->leave_sub();
886 'title_error' => $params{title},
887 'label_error' => $error,
890 if ($params{action}) {
893 map { delete($self->{$_}); } qw(action);
894 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
896 $add_params->{SHOW_BUTTON} = 1;
897 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
898 $add_params->{VARIABLES} = \@vars;
900 } elsif ($params{back_button}) {
901 $add_params->{SHOW_BACK_BUTTON} = 1;
904 $self->{title} = $params{title} if $params{title};
907 print $self->parse_html_template("generic/error", $add_params);
909 print STDERR "Error: $error\n";
911 $main::lxdebug->leave_sub();
916 sub show_generic_information {
917 $main::lxdebug->enter_sub();
919 my ($self, $text, $title) = @_;
922 'title_information' => $title,
923 'label_information' => $text,
926 $self->{title} = $title if ($title);
929 print $self->parse_html_template("generic/information", $add_params);
931 $main::lxdebug->leave_sub();
936 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
937 # changed it to accept an arbitrary number of triggers - sschoeling
939 $main::lxdebug->enter_sub();
942 my $myconfig = shift;
945 # set dateform for jsscript
948 "dd.mm.yy" => "%d.%m.%Y",
949 "dd-mm-yy" => "%d-%m-%Y",
950 "dd/mm/yy" => "%d/%m/%Y",
951 "mm/dd/yy" => "%m/%d/%Y",
952 "mm-dd-yy" => "%m-%d-%Y",
953 "yyyy-mm-dd" => "%Y-%m-%d",
956 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
957 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
964 inputField : "| . (shift) . qq|",
965 ifFormat :"$ifFormat",
966 align : "| . (shift) . qq|",
967 button : "| . (shift) . qq|"
973 <script type="text/javascript">
974 <!--| . join("", @triggers) . qq|//-->
978 $main::lxdebug->leave_sub();
981 } #end sub write_trigger
984 $main::lxdebug->enter_sub();
986 my ($self, $msg) = @_;
988 if (!$self->{callback}) {
994 # my ($script, $argv) = split(/\?/, $self->{callback}, 2);
995 # $script =~ s|.*/||;
996 # $script =~ s|[^a-zA-Z0-9_\.]||g;
997 # exec("perl", "$script", $argv);
999 print $::form->redirect_header($self->{callback});
1001 $main::lxdebug->leave_sub();
1004 # sort of columns removed - empty sub
1006 $main::lxdebug->enter_sub();
1008 my ($self, @columns) = @_;
1010 $main::lxdebug->leave_sub();
1016 $main::lxdebug->enter_sub(2);
1018 my ($self, $myconfig, $amount, $places, $dash) = @_;
1020 if ($amount eq "") {
1024 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1026 my $neg = ($amount =~ s/^-//);
1027 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1029 if (defined($places) && ($places ne '')) {
1035 my ($actual_places) = ($amount =~ /\.(\d+)/);
1036 $actual_places = length($actual_places);
1037 $places = $actual_places > $places ? $actual_places : $places;
1040 $amount = $self->round_amount($amount, $places);
1043 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1044 my @p = split(/\./, $amount); # split amount at decimal point
1046 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1049 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1052 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1053 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1054 ($neg ? "-$amount" : "$amount" ) ;
1058 $main::lxdebug->leave_sub(2);
1062 sub format_amount_units {
1063 $main::lxdebug->enter_sub();
1068 my $myconfig = \%main::myconfig;
1069 my $amount = $params{amount} * 1;
1070 my $places = $params{places};
1071 my $part_unit_name = $params{part_unit};
1072 my $amount_unit_name = $params{amount_unit};
1073 my $conv_units = $params{conv_units};
1074 my $max_places = $params{max_places};
1076 if (!$part_unit_name) {
1077 $main::lxdebug->leave_sub();
1081 AM->retrieve_all_units();
1082 my $all_units = $main::all_units;
1084 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1085 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1088 if (!scalar @{ $conv_units }) {
1089 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1090 $main::lxdebug->leave_sub();
1094 my $part_unit = $all_units->{$part_unit_name};
1095 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1097 $amount *= $conv_unit->{factor};
1102 foreach my $unit (@$conv_units) {
1103 my $last = $unit->{name} eq $part_unit->{name};
1105 $num = int($amount / $unit->{factor});
1106 $amount -= $num * $unit->{factor};
1109 if ($last ? $amount : $num) {
1110 push @values, { "unit" => $unit->{name},
1111 "amount" => $last ? $amount / $unit->{factor} : $num,
1112 "places" => $last ? $places : 0 };
1119 push @values, { "unit" => $part_unit_name,
1124 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1126 $main::lxdebug->leave_sub();
1132 $main::lxdebug->enter_sub(2);
1137 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1138 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1139 $input =~ s/\#\#/\#/g;
1141 $main::lxdebug->leave_sub(2);
1149 $main::lxdebug->enter_sub(2);
1151 my ($self, $myconfig, $amount) = @_;
1153 if ( ($myconfig->{numberformat} eq '1.000,00')
1154 || ($myconfig->{numberformat} eq '1000,00')) {
1159 if ($myconfig->{numberformat} eq "1'000.00") {
1165 $main::lxdebug->leave_sub(2);
1167 return ($amount * 1);
1171 $main::lxdebug->enter_sub(2);
1173 my ($self, $amount, $places) = @_;
1176 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1178 # Round amounts to eight places before rounding to the requested
1179 # number of places. This gets rid of errors due to internal floating
1180 # point representation.
1181 $amount = $self->round_amount($amount, 8) if $places < 8;
1182 $amount = $amount * (10**($places));
1183 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1185 $main::lxdebug->leave_sub(2);
1187 return $round_amount;
1191 sub parse_template {
1192 $main::lxdebug->enter_sub();
1194 my ($self, $myconfig, $userspath) = @_;
1199 $self->{"cwd"} = getcwd();
1200 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1205 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1206 $template_type = 'OpenDocument';
1207 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1209 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1210 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1211 $template_type = 'LaTeX';
1212 $ext_for_format = 'pdf';
1214 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1215 $template_type = 'HTML';
1216 $ext_for_format = 'html';
1218 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1219 $template_type = 'XML';
1220 $ext_for_format = 'xml';
1222 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1223 $template_type = 'XML';
1225 } elsif ( $self->{"format"} =~ /excel/i ) {
1226 $template_type = 'Excel';
1227 $ext_for_format = 'xls';
1229 } elsif ( defined $self->{'format'}) {
1230 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1232 } elsif ( $self->{'format'} eq '' ) {
1233 $self->error("No Outputformat given: $self->{'format'}");
1235 } else { #Catch the rest
1236 $self->error("Outputformat not defined: $self->{'format'}");
1239 my $template = SL::Template::create(type => $template_type,
1240 file_name => $self->{IN},
1242 myconfig => $myconfig,
1243 userspath => $userspath);
1245 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1246 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1248 if (!$self->{employee_id}) {
1249 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1252 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1254 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1256 # OUT is used for the media, screen, printer, email
1257 # for postscript we store a copy in a temporary file
1259 my $prepend_userspath;
1261 if (!$self->{tmpfile}) {
1262 $self->{tmpfile} = "${fileid}.$self->{IN}";
1263 $prepend_userspath = 1;
1266 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1268 $self->{tmpfile} =~ s|.*/||;
1269 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1270 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1272 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1273 $out = $self->{OUT};
1274 $self->{OUT} = ">$self->{tmpfile}";
1280 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1281 $result = $template->parse(*OUT);
1286 $result = $template->parse(*STDOUT);
1291 $self->error("$self->{IN} : " . $template->get_error());
1294 if ($self->{media} eq 'file') {
1295 copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1297 chdir("$self->{cwd}");
1299 $::lxdebug->leave_sub();
1304 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1306 if ($self->{media} eq 'email') {
1308 my $mail = new Mailer;
1310 map { $mail->{$_} = $self->{$_} }
1311 qw(cc bcc subject message version format);
1312 $mail->{charset} = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
1313 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1314 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1315 $mail->{fileid} = "$fileid.";
1316 $myconfig->{signature} =~ s/\r//g;
1318 # if we send html or plain text inline
1319 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1320 $mail->{contenttype} = "text/html";
1322 $mail->{message} =~ s/\r//g;
1323 $mail->{message} =~ s/\n/<br>\n/g;
1324 $myconfig->{signature} =~ s/\n/<br>\n/g;
1325 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1327 open(IN, $self->{tmpfile})
1328 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1330 $mail->{message} .= $_;
1337 if (!$self->{"do_not_attach"}) {
1338 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1339 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1340 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1341 "name" => $attachment_name }];
1344 $mail->{message} =~ s/\r//g;
1345 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1349 my $err = $mail->send();
1350 $self->error($self->cleanup . "$err") if ($err);
1354 $self->{OUT} = $out;
1356 my $numbytes = (-s $self->{tmpfile});
1357 open(IN, $self->{tmpfile})
1358 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1360 $self->{copies} = 1 unless $self->{media} eq 'printer';
1362 chdir("$self->{cwd}");
1363 #print(STDERR "Kopien $self->{copies}\n");
1364 #print(STDERR "OUT $self->{OUT}\n");
1365 for my $i (1 .. $self->{copies}) {
1367 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1368 print OUT while <IN>;
1373 $self->{attachment_filename} = ($self->{attachment_filename})
1374 ? $self->{attachment_filename}
1375 : $self->generate_attachment_filename();
1377 # launch application
1378 print qq|Content-Type: | . $template->get_mime_type() . qq|
1379 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1380 Content-Length: $numbytes
1384 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1395 chdir("$self->{cwd}");
1396 $main::lxdebug->leave_sub();
1399 sub get_formname_translation {
1400 $main::lxdebug->enter_sub();
1401 my ($self, $formname) = @_;
1403 $formname ||= $self->{formname};
1405 my %formname_translations = (
1406 bin_list => $main::locale->text('Bin List'),
1407 credit_note => $main::locale->text('Credit Note'),
1408 invoice => $main::locale->text('Invoice'),
1409 pick_list => $main::locale->text('Pick List'),
1410 proforma => $main::locale->text('Proforma Invoice'),
1411 purchase_order => $main::locale->text('Purchase Order'),
1412 request_quotation => $main::locale->text('RFQ'),
1413 sales_order => $main::locale->text('Confirmation'),
1414 sales_quotation => $main::locale->text('Quotation'),
1415 storno_invoice => $main::locale->text('Storno Invoice'),
1416 sales_delivery_order => $main::locale->text('Delivery Order'),
1417 purchase_delivery_order => $main::locale->text('Delivery Order'),
1418 dunning => $main::locale->text('Dunning'),
1421 $main::lxdebug->leave_sub();
1422 return $formname_translations{$formname}
1425 sub get_number_prefix_for_type {
1426 $main::lxdebug->enter_sub();
1430 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1431 : ($self->{type} =~ /_quotation$/) ? 'quo'
1432 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1435 $main::lxdebug->leave_sub();
1439 sub get_extension_for_format {
1440 $main::lxdebug->enter_sub();
1443 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1444 : $self->{format} =~ /postscript/i ? ".ps"
1445 : $self->{format} =~ /opendocument/i ? ".odt"
1446 : $self->{format} =~ /excel/i ? ".xls"
1447 : $self->{format} =~ /html/i ? ".html"
1450 $main::lxdebug->leave_sub();
1454 sub generate_attachment_filename {
1455 $main::lxdebug->enter_sub();
1458 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1459 my $prefix = $self->get_number_prefix_for_type();
1461 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1462 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1464 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1465 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1468 $attachment_filename = "";
1471 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1472 $attachment_filename =~ s|[\s/\\]+|_|g;
1474 $main::lxdebug->leave_sub();
1475 return $attachment_filename;
1478 sub generate_email_subject {
1479 $main::lxdebug->enter_sub();
1482 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1483 my $prefix = $self->get_number_prefix_for_type();
1485 if ($subject && $self->{"${prefix}number"}) {
1486 $subject .= " " . $self->{"${prefix}number"}
1489 $main::lxdebug->leave_sub();
1494 $main::lxdebug->enter_sub();
1498 chdir("$self->{tmpdir}");
1501 if (-f "$self->{tmpfile}.err") {
1502 open(FH, "$self->{tmpfile}.err");
1507 if ($self->{tmpfile} && ! $::keep_temp_files) {
1508 $self->{tmpfile} =~ s|.*/||g;
1510 $self->{tmpfile} =~ s/\.\w+$//g;
1511 my $tmpfile = $self->{tmpfile};
1512 unlink(<$tmpfile.*>);
1515 chdir("$self->{cwd}");
1517 $main::lxdebug->leave_sub();
1523 $main::lxdebug->enter_sub();
1525 my ($self, $date, $myconfig) = @_;
1528 if ($date && $date =~ /\D/) {
1530 if ($myconfig->{dateformat} =~ /^yy/) {
1531 ($yy, $mm, $dd) = split /\D/, $date;
1533 if ($myconfig->{dateformat} =~ /^mm/) {
1534 ($mm, $dd, $yy) = split /\D/, $date;
1536 if ($myconfig->{dateformat} =~ /^dd/) {
1537 ($dd, $mm, $yy) = split /\D/, $date;
1542 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1543 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1545 $dd = "0$dd" if ($dd < 10);
1546 $mm = "0$mm" if ($mm < 10);
1548 $date = "$yy$mm$dd";
1551 $main::lxdebug->leave_sub();
1556 # Database routines used throughout
1558 sub _dbconnect_options {
1560 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1567 $main::lxdebug->enter_sub(2);
1569 my ($self, $myconfig) = @_;
1571 # connect to database
1572 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1576 if ($myconfig->{dboptions}) {
1577 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1580 $main::lxdebug->leave_sub(2);
1585 sub dbconnect_noauto {
1586 $main::lxdebug->enter_sub();
1588 my ($self, $myconfig) = @_;
1590 # connect to database
1591 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1595 if ($myconfig->{dboptions}) {
1596 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1599 $main::lxdebug->leave_sub();
1604 sub get_standard_dbh {
1605 $main::lxdebug->enter_sub(2);
1608 my $myconfig = shift || \%::myconfig;
1610 if ($standard_dbh && !$standard_dbh->{Active}) {
1611 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1612 undef $standard_dbh;
1615 $standard_dbh ||= SL::DB::create->dbh;
1617 $main::lxdebug->leave_sub(2);
1619 return $standard_dbh;
1623 $main::lxdebug->enter_sub();
1625 my ($self, $date, $myconfig) = @_;
1626 my $dbh = $self->dbconnect($myconfig);
1628 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1629 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1630 my ($closed) = $sth->fetchrow_array;
1632 $main::lxdebug->leave_sub();
1637 sub update_balance {
1638 $main::lxdebug->enter_sub();
1640 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1642 # if we have a value, go do it
1645 # retrieve balance from table
1646 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1647 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1648 my ($balance) = $sth->fetchrow_array;
1654 $query = "UPDATE $table SET $field = $balance WHERE $where";
1655 do_query($self, $dbh, $query, @values);
1657 $main::lxdebug->leave_sub();
1660 sub update_exchangerate {
1661 $main::lxdebug->enter_sub();
1663 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1665 # some sanity check for currency
1667 $main::lxdebug->leave_sub();
1670 $query = qq|SELECT curr FROM defaults|;
1672 my ($currency) = selectrow_query($self, $dbh, $query);
1673 my ($defaultcurrency) = split m/:/, $currency;
1676 if ($curr eq $defaultcurrency) {
1677 $main::lxdebug->leave_sub();
1681 $query = qq|SELECT e.curr FROM exchangerate e
1682 WHERE e.curr = ? AND e.transdate = ?
1684 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1693 $buy = conv_i($buy, "NULL");
1694 $sell = conv_i($sell, "NULL");
1697 if ($buy != 0 && $sell != 0) {
1698 $set = "buy = $buy, sell = $sell";
1699 } elsif ($buy != 0) {
1700 $set = "buy = $buy";
1701 } elsif ($sell != 0) {
1702 $set = "sell = $sell";
1705 if ($sth->fetchrow_array) {
1706 $query = qq|UPDATE exchangerate
1712 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1713 VALUES (?, $buy, $sell, ?)|;
1716 do_query($self, $dbh, $query, $curr, $transdate);
1718 $main::lxdebug->leave_sub();
1721 sub save_exchangerate {
1722 $main::lxdebug->enter_sub();
1724 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1726 my $dbh = $self->dbconnect($myconfig);
1730 $buy = $rate if $fld eq 'buy';
1731 $sell = $rate if $fld eq 'sell';
1734 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1739 $main::lxdebug->leave_sub();
1742 sub get_exchangerate {
1743 $main::lxdebug->enter_sub();
1745 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1748 unless ($transdate) {
1749 $main::lxdebug->leave_sub();
1753 $query = qq|SELECT curr FROM defaults|;
1755 my ($currency) = selectrow_query($self, $dbh, $query);
1756 my ($defaultcurrency) = split m/:/, $currency;
1758 if ($currency eq $defaultcurrency) {
1759 $main::lxdebug->leave_sub();
1763 $query = qq|SELECT e.$fld FROM exchangerate e
1764 WHERE e.curr = ? AND e.transdate = ?|;
1765 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1769 $main::lxdebug->leave_sub();
1771 return $exchangerate;
1774 sub check_exchangerate {
1775 $main::lxdebug->enter_sub();
1777 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1779 if ($fld !~/^buy|sell$/) {
1780 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1783 unless ($transdate) {
1784 $main::lxdebug->leave_sub();
1788 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1790 if ($currency eq $defaultcurrency) {
1791 $main::lxdebug->leave_sub();
1795 my $dbh = $self->get_standard_dbh($myconfig);
1796 my $query = qq|SELECT e.$fld FROM exchangerate e
1797 WHERE e.curr = ? AND e.transdate = ?|;
1799 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1801 $main::lxdebug->leave_sub();
1803 return $exchangerate;
1806 sub get_all_currencies {
1807 $main::lxdebug->enter_sub();
1810 my $myconfig = shift || \%::myconfig;
1811 my $dbh = $self->get_standard_dbh($myconfig);
1813 my $query = qq|SELECT curr FROM defaults|;
1815 my ($curr) = selectrow_query($self, $dbh, $query);
1816 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1818 $main::lxdebug->leave_sub();
1823 sub get_default_currency {
1824 $main::lxdebug->enter_sub();
1826 my ($self, $myconfig) = @_;
1827 my @currencies = $self->get_all_currencies($myconfig);
1829 $main::lxdebug->leave_sub();
1831 return $currencies[0];
1834 sub set_payment_options {
1835 $main::lxdebug->enter_sub();
1837 my ($self, $myconfig, $transdate) = @_;
1839 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1841 my $dbh = $self->get_standard_dbh($myconfig);
1844 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1845 qq|FROM payment_terms p | .
1848 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1849 $self->{payment_terms}) =
1850 selectrow_query($self, $dbh, $query, $self->{payment_id});
1852 if ($transdate eq "") {
1853 if ($self->{invdate}) {
1854 $transdate = $self->{invdate};
1856 $transdate = $self->{transdate};
1861 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1862 qq|FROM payment_terms|;
1863 ($self->{netto_date}, $self->{skonto_date}) =
1864 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1866 my ($invtotal, $total);
1867 my (%amounts, %formatted_amounts);
1869 if ($self->{type} =~ /_order$/) {
1870 $amounts{invtotal} = $self->{ordtotal};
1871 $amounts{total} = $self->{ordtotal};
1873 } elsif ($self->{type} =~ /_quotation$/) {
1874 $amounts{invtotal} = $self->{quototal};
1875 $amounts{total} = $self->{quototal};
1878 $amounts{invtotal} = $self->{invtotal};
1879 $amounts{total} = $self->{total};
1881 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1883 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1885 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1886 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1887 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1889 foreach (keys %amounts) {
1890 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1891 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1894 if ($self->{"language_id"}) {
1896 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1897 qq|FROM translation_payment_terms t | .
1898 qq|LEFT JOIN language l ON t.language_id = l.id | .
1899 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1900 my ($description_long, $output_numberformat, $output_dateformat,
1901 $output_longdates) =
1902 selectrow_query($self, $dbh, $query,
1903 $self->{"language_id"}, $self->{"payment_id"});
1905 $self->{payment_terms} = $description_long if ($description_long);
1907 if ($output_dateformat) {
1908 foreach my $key (qw(netto_date skonto_date)) {
1910 $main::locale->reformat_date($myconfig, $self->{$key},
1916 if ($output_numberformat &&
1917 ($output_numberformat ne $myconfig->{"numberformat"})) {
1918 my $saved_numberformat = $myconfig->{"numberformat"};
1919 $myconfig->{"numberformat"} = $output_numberformat;
1920 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1921 $myconfig->{"numberformat"} = $saved_numberformat;
1925 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1926 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1927 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1928 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1929 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1930 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1931 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1933 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1935 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1937 $main::lxdebug->leave_sub();
1941 sub get_template_language {
1942 $main::lxdebug->enter_sub();
1944 my ($self, $myconfig) = @_;
1946 my $template_code = "";
1948 if ($self->{language_id}) {
1949 my $dbh = $self->get_standard_dbh($myconfig);
1950 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1951 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1954 $main::lxdebug->leave_sub();
1956 return $template_code;
1959 sub get_printer_code {
1960 $main::lxdebug->enter_sub();
1962 my ($self, $myconfig) = @_;
1964 my $template_code = "";
1966 if ($self->{printer_id}) {
1967 my $dbh = $self->get_standard_dbh($myconfig);
1968 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1969 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1972 $main::lxdebug->leave_sub();
1974 return $template_code;
1978 $main::lxdebug->enter_sub();
1980 my ($self, $myconfig) = @_;
1982 my $template_code = "";
1984 if ($self->{shipto_id}) {
1985 my $dbh = $self->get_standard_dbh($myconfig);
1986 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1987 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1988 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1991 $main::lxdebug->leave_sub();
1995 $main::lxdebug->enter_sub();
1997 my ($self, $dbh, $id, $module) = @_;
2002 foreach my $item (qw(name department_1 department_2 street zipcode city country
2003 contact cp_gender phone fax email)) {
2004 if ($self->{"shipto$item"}) {
2005 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2007 push(@values, $self->{"shipto${item}"});
2011 if ($self->{shipto_id}) {
2012 my $query = qq|UPDATE shipto set
2014 shiptodepartment_1 = ?,
2015 shiptodepartment_2 = ?,
2021 shiptocp_gender = ?,
2025 WHERE shipto_id = ?|;
2026 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2028 my $query = qq|SELECT * FROM shipto
2029 WHERE shiptoname = ? AND
2030 shiptodepartment_1 = ? AND
2031 shiptodepartment_2 = ? AND
2032 shiptostreet = ? AND
2033 shiptozipcode = ? AND
2035 shiptocountry = ? AND
2036 shiptocontact = ? AND
2037 shiptocp_gender = ? AND
2043 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2046 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2047 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2048 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2049 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2050 do_query($self, $dbh, $query, $id, @values, $module);
2055 $main::lxdebug->leave_sub();
2059 $main::lxdebug->enter_sub();
2061 my ($self, $dbh) = @_;
2063 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2065 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2066 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2067 $self->{"employee_id"} *= 1;
2069 $main::lxdebug->leave_sub();
2072 sub get_employee_data {
2073 $main::lxdebug->enter_sub();
2078 Common::check_params(\%params, qw(prefix));
2079 Common::check_params_x(\%params, qw(id));
2082 $main::lxdebug->leave_sub();
2086 my $myconfig = \%main::myconfig;
2087 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2089 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2092 my $user = User->new($login);
2093 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2095 $self->{$params{prefix} . '_login'} = $login;
2096 $self->{$params{prefix} . '_name'} ||= $login;
2099 $main::lxdebug->leave_sub();
2103 $main::lxdebug->enter_sub();
2105 my ($self, $myconfig, $reference_date) = @_;
2107 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2109 my $dbh = $self->get_standard_dbh($myconfig);
2110 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2111 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2113 $main::lxdebug->leave_sub();
2119 $main::lxdebug->enter_sub();
2121 my ($self, $dbh, $id, $key) = @_;
2123 $key = "all_contacts" unless ($key);
2127 $main::lxdebug->leave_sub();
2132 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2133 qq|FROM contacts | .
2134 qq|WHERE cp_cv_id = ? | .
2135 qq|ORDER BY lower(cp_name)|;
2137 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2139 $main::lxdebug->leave_sub();
2143 $main::lxdebug->enter_sub();
2145 my ($self, $dbh, $key) = @_;
2147 my ($all, $old_id, $where, @values);
2149 if (ref($key) eq "HASH") {
2152 $key = "ALL_PROJECTS";
2154 foreach my $p (keys(%{$params})) {
2156 $all = $params->{$p};
2157 } elsif ($p eq "old_id") {
2158 $old_id = $params->{$p};
2159 } elsif ($p eq "key") {
2160 $key = $params->{$p};
2166 $where = "WHERE active ";
2168 if (ref($old_id) eq "ARRAY") {
2169 my @ids = grep({ $_ } @{$old_id});
2171 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2172 push(@values, @ids);
2175 $where .= " OR (id = ?) ";
2176 push(@values, $old_id);
2182 qq|SELECT id, projectnumber, description, active | .
2185 qq|ORDER BY lower(projectnumber)|;
2187 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2189 $main::lxdebug->leave_sub();
2193 $main::lxdebug->enter_sub();
2195 my ($self, $dbh, $vc_id, $key) = @_;
2197 $key = "all_shipto" unless ($key);
2200 # get shipping addresses
2201 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2203 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2209 $main::lxdebug->leave_sub();
2213 $main::lxdebug->enter_sub();
2215 my ($self, $dbh, $key) = @_;
2217 $key = "all_printers" unless ($key);
2219 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2221 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2223 $main::lxdebug->leave_sub();
2227 $main::lxdebug->enter_sub();
2229 my ($self, $dbh, $params) = @_;
2232 $key = $params->{key};
2233 $key = "all_charts" unless ($key);
2235 my $transdate = quote_db_date($params->{transdate});
2238 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2240 qq|LEFT JOIN taxkeys tk ON | .
2241 qq|(tk.id = (SELECT id FROM taxkeys | .
2242 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2243 qq| ORDER BY startdate DESC LIMIT 1)) | .
2244 qq|ORDER BY c.accno|;
2246 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2248 $main::lxdebug->leave_sub();
2251 sub _get_taxcharts {
2252 $main::lxdebug->enter_sub();
2254 my ($self, $dbh, $params) = @_;
2256 my $key = "all_taxcharts";
2259 if (ref $params eq 'HASH') {
2260 $key = $params->{key} if ($params->{key});
2261 if ($params->{module} eq 'AR') {
2262 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2264 } elsif ($params->{module} eq 'AP') {
2265 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2272 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2274 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2276 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2278 $main::lxdebug->leave_sub();
2282 $main::lxdebug->enter_sub();
2284 my ($self, $dbh, $key) = @_;
2286 $key = "all_taxzones" unless ($key);
2288 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2290 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2292 $main::lxdebug->leave_sub();
2295 sub _get_employees {
2296 $main::lxdebug->enter_sub();
2298 my ($self, $dbh, $default_key, $key) = @_;
2300 $key = $default_key unless ($key);
2301 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2303 $main::lxdebug->leave_sub();
2306 sub _get_business_types {
2307 $main::lxdebug->enter_sub();
2309 my ($self, $dbh, $key) = @_;
2311 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2312 $options->{key} ||= "all_business_types";
2315 if (exists $options->{salesman}) {
2316 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2319 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2321 $main::lxdebug->leave_sub();
2324 sub _get_languages {
2325 $main::lxdebug->enter_sub();
2327 my ($self, $dbh, $key) = @_;
2329 $key = "all_languages" unless ($key);
2331 my $query = qq|SELECT * FROM language ORDER BY id|;
2333 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2335 $main::lxdebug->leave_sub();
2338 sub _get_dunning_configs {
2339 $main::lxdebug->enter_sub();
2341 my ($self, $dbh, $key) = @_;
2343 $key = "all_dunning_configs" unless ($key);
2345 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2347 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2349 $main::lxdebug->leave_sub();
2352 sub _get_currencies {
2353 $main::lxdebug->enter_sub();
2355 my ($self, $dbh, $key) = @_;
2357 $key = "all_currencies" unless ($key);
2359 my $query = qq|SELECT curr AS currency FROM defaults|;
2361 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2363 $main::lxdebug->leave_sub();
2367 $main::lxdebug->enter_sub();
2369 my ($self, $dbh, $key) = @_;
2371 $key = "all_payments" unless ($key);
2373 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2375 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2377 $main::lxdebug->leave_sub();
2380 sub _get_customers {
2381 $main::lxdebug->enter_sub();
2383 my ($self, $dbh, $key) = @_;
2385 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2386 $options->{key} ||= "all_customers";
2387 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2390 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2391 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2392 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2394 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2395 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2397 $main::lxdebug->leave_sub();
2401 $main::lxdebug->enter_sub();
2403 my ($self, $dbh, $key) = @_;
2405 $key = "all_vendors" unless ($key);
2407 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2409 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2411 $main::lxdebug->leave_sub();
2414 sub _get_departments {
2415 $main::lxdebug->enter_sub();
2417 my ($self, $dbh, $key) = @_;
2419 $key = "all_departments" unless ($key);
2421 my $query = qq|SELECT * FROM department ORDER BY description|;
2423 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2425 $main::lxdebug->leave_sub();
2428 sub _get_warehouses {
2429 $main::lxdebug->enter_sub();
2431 my ($self, $dbh, $param) = @_;
2433 my ($key, $bins_key);
2435 if ('' eq ref $param) {
2439 $key = $param->{key};
2440 $bins_key = $param->{bins};
2443 my $query = qq|SELECT w.* FROM warehouse w
2444 WHERE (NOT w.invalid) AND
2445 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2446 ORDER BY w.sortkey|;
2448 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2451 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2452 my $sth = prepare_query($self, $dbh, $query);
2454 foreach my $warehouse (@{ $self->{$key} }) {
2455 do_statement($self, $sth, $query, $warehouse->{id});
2456 $warehouse->{$bins_key} = [];
2458 while (my $ref = $sth->fetchrow_hashref()) {
2459 push @{ $warehouse->{$bins_key} }, $ref;
2465 $main::lxdebug->leave_sub();
2469 $main::lxdebug->enter_sub();
2471 my ($self, $dbh, $table, $key, $sortkey) = @_;
2473 my $query = qq|SELECT * FROM $table|;
2474 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2476 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2478 $main::lxdebug->leave_sub();
2482 # $main::lxdebug->enter_sub();
2484 # my ($self, $dbh, $key) = @_;
2486 # $key ||= "all_groups";
2488 # my $groups = $main::auth->read_groups();
2490 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2492 # $main::lxdebug->leave_sub();
2496 $main::lxdebug->enter_sub();
2501 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2502 my ($sth, $query, $ref);
2504 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2505 my $vc_id = $self->{"${vc}_id"};
2507 if ($params{"contacts"}) {
2508 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2511 if ($params{"shipto"}) {
2512 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2515 if ($params{"projects"} || $params{"all_projects"}) {
2516 $self->_get_projects($dbh, $params{"all_projects"} ?
2517 $params{"all_projects"} : $params{"projects"},
2518 $params{"all_projects"} ? 1 : 0);
2521 if ($params{"printers"}) {
2522 $self->_get_printers($dbh, $params{"printers"});
2525 if ($params{"languages"}) {
2526 $self->_get_languages($dbh, $params{"languages"});
2529 if ($params{"charts"}) {
2530 $self->_get_charts($dbh, $params{"charts"});
2533 if ($params{"taxcharts"}) {
2534 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2537 if ($params{"taxzones"}) {
2538 $self->_get_taxzones($dbh, $params{"taxzones"});
2541 if ($params{"employees"}) {
2542 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2545 if ($params{"salesmen"}) {
2546 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2549 if ($params{"business_types"}) {
2550 $self->_get_business_types($dbh, $params{"business_types"});
2553 if ($params{"dunning_configs"}) {
2554 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2557 if($params{"currencies"}) {
2558 $self->_get_currencies($dbh, $params{"currencies"});
2561 if($params{"customers"}) {
2562 $self->_get_customers($dbh, $params{"customers"});
2565 if($params{"vendors"}) {
2566 if (ref $params{"vendors"} eq 'HASH') {
2567 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2569 $self->_get_vendors($dbh, $params{"vendors"});
2573 if($params{"payments"}) {
2574 $self->_get_payments($dbh, $params{"payments"});
2577 if($params{"departments"}) {
2578 $self->_get_departments($dbh, $params{"departments"});
2581 if ($params{price_factors}) {
2582 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2585 if ($params{warehouses}) {
2586 $self->_get_warehouses($dbh, $params{warehouses});
2589 # if ($params{groups}) {
2590 # $self->_get_groups($dbh, $params{groups});
2593 if ($params{partsgroup}) {
2594 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2597 $main::lxdebug->leave_sub();
2600 # this sub gets the id and name from $table
2602 $main::lxdebug->enter_sub();
2604 my ($self, $myconfig, $table) = @_;
2606 # connect to database
2607 my $dbh = $self->get_standard_dbh($myconfig);
2609 $table = $table eq "customer" ? "customer" : "vendor";
2610 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2612 my ($query, @values);
2614 if (!$self->{openinvoices}) {
2616 if ($self->{customernumber} ne "") {
2617 $where = qq|(vc.customernumber ILIKE ?)|;
2618 push(@values, '%' . $self->{customernumber} . '%');
2620 $where = qq|(vc.name ILIKE ?)|;
2621 push(@values, '%' . $self->{$table} . '%');
2625 qq~SELECT vc.id, vc.name,
2626 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2628 WHERE $where AND (NOT vc.obsolete)
2632 qq~SELECT DISTINCT vc.id, vc.name,
2633 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2635 JOIN $table vc ON (a.${table}_id = vc.id)
2636 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2638 push(@values, '%' . $self->{$table} . '%');
2641 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2643 $main::lxdebug->leave_sub();
2645 return scalar(@{ $self->{name_list} });
2648 # the selection sub is used in the AR, AP, IS, IR and OE module
2651 $main::lxdebug->enter_sub();
2653 my ($self, $myconfig, $table, $module) = @_;
2656 my $dbh = $self->get_standard_dbh;
2658 $table = $table eq "customer" ? "customer" : "vendor";
2660 my $query = qq|SELECT count(*) FROM $table|;
2661 my ($count) = selectrow_query($self, $dbh, $query);
2663 # build selection list
2664 if ($count <= $myconfig->{vclimit}) {
2665 $query = qq|SELECT id, name, salesman_id
2666 FROM $table WHERE NOT obsolete
2668 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2672 $self->get_employee($dbh);
2674 # setup sales contacts
2675 $query = qq|SELECT e.id, e.name
2677 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2678 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2681 push(@{ $self->{all_employees} },
2682 { id => $self->{employee_id},
2683 name => $self->{employee} });
2685 # sort the whole thing
2686 @{ $self->{all_employees} } =
2687 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2689 if ($module eq 'AR') {
2691 # prepare query for departments
2692 $query = qq|SELECT id, description
2695 ORDER BY description|;
2698 $query = qq|SELECT id, description
2700 ORDER BY description|;
2703 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2706 $query = qq|SELECT id, description
2710 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2713 $query = qq|SELECT printer_description, id
2715 ORDER BY printer_description|;
2717 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2720 $query = qq|SELECT id, description
2724 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2726 $main::lxdebug->leave_sub();
2729 sub language_payment {
2730 $main::lxdebug->enter_sub();
2732 my ($self, $myconfig) = @_;
2734 my $dbh = $self->get_standard_dbh($myconfig);
2736 my $query = qq|SELECT id, description
2740 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2743 $query = qq|SELECT printer_description, id
2745 ORDER BY printer_description|;
2747 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2750 $query = qq|SELECT id, description
2754 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2756 # get buchungsgruppen
2757 $query = qq|SELECT id, description
2758 FROM buchungsgruppen|;
2760 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2762 $main::lxdebug->leave_sub();
2765 # this is only used for reports
2766 sub all_departments {
2767 $main::lxdebug->enter_sub();
2769 my ($self, $myconfig, $table) = @_;
2771 my $dbh = $self->get_standard_dbh($myconfig);
2774 if ($table eq 'customer') {
2775 $where = "WHERE role = 'P' ";
2778 my $query = qq|SELECT id, description
2781 ORDER BY description|;
2782 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2784 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2786 $main::lxdebug->leave_sub();
2790 $main::lxdebug->enter_sub();
2792 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2795 if ($table eq "customer") {
2804 $self->all_vc($myconfig, $table, $module);
2806 # get last customers or vendors
2807 my ($query, $sth, $ref);
2809 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2814 my $transdate = "current_date";
2815 if ($self->{transdate}) {
2816 $transdate = $dbh->quote($self->{transdate});
2819 # now get the account numbers
2820 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2821 FROM chart c, taxkeys tk
2822 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2823 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2826 $sth = $dbh->prepare($query);
2828 do_statement($self, $sth, $query, '%' . $module . '%');
2830 $self->{accounts} = "";
2831 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2833 foreach my $key (split(/:/, $ref->{link})) {
2834 if ($key =~ /\Q$module\E/) {
2836 # cross reference for keys
2837 $xkeyref{ $ref->{accno} } = $key;
2839 push @{ $self->{"${module}_links"}{$key} },
2840 { accno => $ref->{accno},
2841 description => $ref->{description},
2842 taxkey => $ref->{taxkey_id},
2843 tax_id => $ref->{tax_id} };
2845 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2851 # get taxkeys and description
2852 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2853 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2855 if (($module eq "AP") || ($module eq "AR")) {
2856 # get tax rates and description
2857 $query = qq|SELECT * FROM tax|;
2858 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2864 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2865 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2866 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2867 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2869 d.description AS department,
2872 JOIN $table c ON (a.${table}_id = c.id)
2873 LEFT JOIN employee e ON (e.id = a.employee_id)
2874 LEFT JOIN department d ON (d.id = a.department_id)
2876 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2878 foreach my $key (keys %$ref) {
2879 $self->{$key} = $ref->{$key};
2882 my $transdate = "current_date";
2883 if ($self->{transdate}) {
2884 $transdate = $dbh->quote($self->{transdate});
2887 # now get the account numbers
2888 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2890 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2892 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2893 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2896 $sth = $dbh->prepare($query);
2897 do_statement($self, $sth, $query, "%$module%");
2899 $self->{accounts} = "";
2900 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2902 foreach my $key (split(/:/, $ref->{link})) {
2903 if ($key =~ /\Q$module\E/) {
2905 # cross reference for keys
2906 $xkeyref{ $ref->{accno} } = $key;
2908 push @{ $self->{"${module}_links"}{$key} },
2909 { accno => $ref->{accno},
2910 description => $ref->{description},
2911 taxkey => $ref->{taxkey_id},
2912 tax_id => $ref->{tax_id} };
2914 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2920 # get amounts from individual entries
2923 c.accno, c.description,
2924 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2928 LEFT JOIN chart c ON (c.id = a.chart_id)
2929 LEFT JOIN project p ON (p.id = a.project_id)
2930 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2931 WHERE (tk.taxkey_id=a.taxkey) AND
2932 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2933 THEN tk.chart_id = a.chart_id
2936 OR (c.link='%tax%')) AND
2937 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2938 WHERE a.trans_id = ?
2939 AND a.fx_transaction = '0'
2940 ORDER BY a.acc_trans_id, a.transdate|;
2941 $sth = $dbh->prepare($query);
2942 do_statement($self, $sth, $query, $self->{id});
2944 # get exchangerate for currency
2945 $self->{exchangerate} =
2946 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2949 # store amounts in {acc_trans}{$key} for multiple accounts
2950 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2951 $ref->{exchangerate} =
2952 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2953 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2956 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2957 $ref->{amount} *= -1;
2959 $ref->{index} = $index;
2961 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2967 d.curr AS currencies, d.closedto, d.revtrans,
2968 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2969 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2971 $ref = selectfirst_hashref_query($self, $dbh, $query);
2972 map { $self->{$_} = $ref->{$_} } keys %$ref;
2979 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2980 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2981 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2983 $ref = selectfirst_hashref_query($self, $dbh, $query);
2984 map { $self->{$_} = $ref->{$_} } keys %$ref;
2986 if ($self->{"$self->{vc}_id"}) {
2988 # only setup currency
2989 ($self->{currency}) = split(/:/, $self->{currencies});
2993 $self->lastname_used($dbh, $myconfig, $table, $module);
2995 # get exchangerate for currency
2996 $self->{exchangerate} =
2997 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3003 $main::lxdebug->leave_sub();
3007 $main::lxdebug->enter_sub();
3009 my ($self, $dbh, $myconfig, $table, $module) = @_;
3013 $table = $table eq "customer" ? "customer" : "vendor";
3014 my %column_map = ("a.curr" => "currency",
3015 "a.${table}_id" => "${table}_id",
3016 "a.department_id" => "department_id",
3017 "d.description" => "department",
3018 "ct.name" => $table,
3019 "current_date + ct.terms" => "duedate",
3022 if ($self->{type} =~ /delivery_order/) {
3023 $arap = 'delivery_orders';
3024 delete $column_map{"a.curr"};
3026 } elsif ($self->{type} =~ /_order/) {
3028 $where = "quotation = '0'";
3030 } elsif ($self->{type} =~ /_quotation/) {
3032 $where = "quotation = '1'";
3034 } elsif ($table eq 'customer') {
3042 $where = "($where) AND" if ($where);
3043 my $query = qq|SELECT MAX(id) FROM $arap
3044 WHERE $where ${table}_id > 0|;
3045 my ($trans_id) = selectrow_query($self, $dbh, $query);
3048 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3049 $query = qq|SELECT $column_spec
3051 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3052 LEFT JOIN department d ON (a.department_id = d.id)
3054 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3056 map { $self->{$_} = $ref->{$_} } values %column_map;
3058 $main::lxdebug->leave_sub();
3062 $main::lxdebug->enter_sub();
3065 my $myconfig = shift || \%::myconfig;
3066 my ($thisdate, $days) = @_;
3068 my $dbh = $self->get_standard_dbh($myconfig);
3073 my $dateformat = $myconfig->{dateformat};
3074 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3075 $thisdate = $dbh->quote($thisdate);
3076 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3078 $query = qq|SELECT current_date AS thisdate|;
3081 ($thisdate) = selectrow_query($self, $dbh, $query);
3083 $main::lxdebug->leave_sub();
3089 $main::lxdebug->enter_sub();
3091 my ($self, $string) = @_;
3093 if ($string !~ /%/) {
3094 $string = "%$string%";
3097 $string =~ s/\'/\'\'/g;
3099 $main::lxdebug->leave_sub();
3105 $main::lxdebug->enter_sub();
3107 my ($self, $flds, $new, $count, $numrows) = @_;
3111 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3116 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3118 my $j = $item->{ndx} - 1;
3119 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3123 for $i ($count + 1 .. $numrows) {
3124 map { delete $self->{"${_}_$i"} } @{$flds};
3127 $main::lxdebug->leave_sub();
3131 $main::lxdebug->enter_sub();
3133 my ($self, $myconfig) = @_;
3137 my $dbh = $self->dbconnect_noauto($myconfig);
3139 my $query = qq|DELETE FROM status
3140 WHERE (formname = ?) AND (trans_id = ?)|;
3141 my $sth = prepare_query($self, $dbh, $query);
3143 if ($self->{formname} =~ /(check|receipt)/) {
3144 for $i (1 .. $self->{rowcount}) {
3145 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3148 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3152 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3153 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3155 my %queued = split / /, $self->{queued};
3158 if ($self->{formname} =~ /(check|receipt)/) {
3160 # this is a check or receipt, add one entry for each lineitem
3161 my ($accno) = split /--/, $self->{account};
3162 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3163 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3164 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3165 $sth = prepare_query($self, $dbh, $query);
3167 for $i (1 .. $self->{rowcount}) {
3168 if ($self->{"checked_$i"}) {
3169 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3175 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3176 VALUES (?, ?, ?, ?, ?)|;
3177 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3178 $queued{$self->{formname}}, $self->{formname});
3184 $main::lxdebug->leave_sub();
3188 $main::lxdebug->enter_sub();
3190 my ($self, $dbh) = @_;
3192 my ($query, $printed, $emailed);
3194 my $formnames = $self->{printed};
3195 my $emailforms = $self->{emailed};
3197 $query = qq|DELETE FROM status
3198 WHERE (formname = ?) AND (trans_id = ?)|;
3199 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3201 # this only applies to the forms
3202 # checks and receipts are posted when printed or queued
3204 if ($self->{queued}) {
3205 my %queued = split / /, $self->{queued};
3207 foreach my $formname (keys %queued) {
3208 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3209 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3211 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3212 VALUES (?, ?, ?, ?, ?)|;
3213 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3215 $formnames =~ s/\Q$self->{formname}\E//;
3216 $emailforms =~ s/\Q$self->{formname}\E//;
3221 # save printed, emailed info
3222 $formnames =~ s/^ +//g;
3223 $emailforms =~ s/^ +//g;
3226 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3227 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3229 foreach my $formname (keys %status) {
3230 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3231 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3233 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3234 VALUES (?, ?, ?, ?)|;
3235 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3238 $main::lxdebug->leave_sub();
3242 # $main::locale->text('SAVED')
3243 # $main::locale->text('DELETED')
3244 # $main::locale->text('ADDED')
3245 # $main::locale->text('PAYMENT POSTED')
3246 # $main::locale->text('POSTED')
3247 # $main::locale->text('POSTED AS NEW')
3248 # $main::locale->text('ELSE')
3249 # $main::locale->text('SAVED FOR DUNNING')
3250 # $main::locale->text('DUNNING STARTED')
3251 # $main::locale->text('PRINTED')
3252 # $main::locale->text('MAILED')
3253 # $main::locale->text('SCREENED')
3254 # $main::locale->text('CANCELED')
3255 # $main::locale->text('invoice')
3256 # $main::locale->text('proforma')
3257 # $main::locale->text('sales_order')
3258 # $main::locale->text('pick_list')
3259 # $main::locale->text('purchase_order')
3260 # $main::locale->text('bin_list')
3261 # $main::locale->text('sales_quotation')
3262 # $main::locale->text('request_quotation')
3265 $main::lxdebug->enter_sub();
3268 my $dbh = shift || $self->get_standard_dbh;
3270 if(!exists $self->{employee_id}) {
3271 &get_employee($self, $dbh);
3275 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3276 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3277 my @values = (conv_i($self->{id}), $self->{login},
3278 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3279 do_query($self, $dbh, $query, @values);
3283 $main::lxdebug->leave_sub();
3287 $main::lxdebug->enter_sub();
3289 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3290 my ($orderBy, $desc) = split(/\-\-/, $order);
3291 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3294 if ($trans_id ne "") {
3296 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 | .
3297 qq|FROM history_erp h | .
3298 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3299 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3302 my $sth = $dbh->prepare($query) || $self->dberror($query);
3304 $sth->execute() || $self->dberror("$query");
3306 while(my $hash_ref = $sth->fetchrow_hashref()) {
3307 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3308 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3309 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3310 $tempArray[$i++] = $hash_ref;
3312 $main::lxdebug->leave_sub() and return \@tempArray
3313 if ($i > 0 && $tempArray[0] ne "");
3315 $main::lxdebug->leave_sub();
3319 sub update_defaults {
3320 $main::lxdebug->enter_sub();
3322 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3325 if ($provided_dbh) {
3326 $dbh = $provided_dbh;
3328 $dbh = $self->dbconnect_noauto($myconfig);
3330 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3331 my $sth = $dbh->prepare($query);
3333 $sth->execute || $self->dberror($query);
3334 my ($var) = $sth->fetchrow_array;
3337 if ($var =~ m/\d+$/) {
3338 my $new_var = (substr $var, $-[0]) * 1 + 1;
3339 my $len_diff = length($var) - $-[0] - length($new_var);
3340 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3346 $query = qq|UPDATE defaults SET $fld = ?|;
3347 do_query($self, $dbh, $query, $var);
3349 if (!$provided_dbh) {
3354 $main::lxdebug->leave_sub();
3359 sub update_business {
3360 $main::lxdebug->enter_sub();
3362 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3365 if ($provided_dbh) {
3366 $dbh = $provided_dbh;
3368 $dbh = $self->dbconnect_noauto($myconfig);
3371 qq|SELECT customernumberinit FROM business
3372 WHERE id = ? FOR UPDATE|;
3373 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3375 return undef unless $var;
3377 if ($var =~ m/\d+$/) {
3378 my $new_var = (substr $var, $-[0]) * 1 + 1;
3379 my $len_diff = length($var) - $-[0] - length($new_var);
3380 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3386 $query = qq|UPDATE business
3387 SET customernumberinit = ?
3389 do_query($self, $dbh, $query, $var, $business_id);
3391 if (!$provided_dbh) {
3396 $main::lxdebug->leave_sub();
3401 sub get_partsgroup {
3402 $main::lxdebug->enter_sub();
3404 my ($self, $myconfig, $p) = @_;
3405 my $target = $p->{target} || 'all_partsgroup';
3407 my $dbh = $self->get_standard_dbh($myconfig);
3409 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3411 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3414 if ($p->{searchitems} eq 'part') {
3415 $query .= qq|WHERE p.inventory_accno_id > 0|;
3417 if ($p->{searchitems} eq 'service') {
3418 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3420 if ($p->{searchitems} eq 'assembly') {
3421 $query .= qq|WHERE p.assembly = '1'|;
3423 if ($p->{searchitems} eq 'labor') {
3424 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3427 $query .= qq|ORDER BY partsgroup|;
3430 $query = qq|SELECT id, partsgroup FROM partsgroup
3431 ORDER BY partsgroup|;
3434 if ($p->{language_code}) {
3435 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3436 t.description AS translation
3438 JOIN parts p ON (p.partsgroup_id = pg.id)
3439 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3440 ORDER BY translation|;
3441 @values = ($p->{language_code});
3444 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3446 $main::lxdebug->leave_sub();
3449 sub get_pricegroup {
3450 $main::lxdebug->enter_sub();
3452 my ($self, $myconfig, $p) = @_;
3454 my $dbh = $self->get_standard_dbh($myconfig);
3456 my $query = qq|SELECT p.id, p.pricegroup
3459 $query .= qq| ORDER BY pricegroup|;
3462 $query = qq|SELECT id, pricegroup FROM pricegroup
3463 ORDER BY pricegroup|;
3466 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3468 $main::lxdebug->leave_sub();
3472 # usage $form->all_years($myconfig, [$dbh])
3473 # return list of all years where bookings found
3476 $main::lxdebug->enter_sub();
3478 my ($self, $myconfig, $dbh) = @_;
3480 $dbh ||= $self->get_standard_dbh($myconfig);
3483 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3484 (SELECT MAX(transdate) FROM acc_trans)|;
3485 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3487 if ($myconfig->{dateformat} =~ /^yy/) {
3488 ($startdate) = split /\W/, $startdate;
3489 ($enddate) = split /\W/, $enddate;
3491 (@_) = split /\W/, $startdate;
3493 (@_) = split /\W/, $enddate;
3498 $startdate = substr($startdate,0,4);
3499 $enddate = substr($enddate,0,4);
3501 while ($enddate >= $startdate) {
3502 push @all_years, $enddate--;
3507 $main::lxdebug->leave_sub();
3511 $main::lxdebug->enter_sub();
3515 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3517 $main::lxdebug->leave_sub();
3521 $main::lxdebug->enter_sub();
3526 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3528 $main::lxdebug->leave_sub();
3531 sub prepare_for_printing {
3534 $self->{templates} ||= $::myconfig{templates};
3535 $self->{formname} ||= $self->{type};
3536 $self->{media} ||= 'email';
3538 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3540 # set shipto from billto unless set
3541 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3542 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3543 $self->{shiptoname} = $::myconfig{company};
3544 $self->{shiptostreet} = $::myconfig{address};
3547 my $language = $self->{language} ? '_' . $self->{language} : '';
3549 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3550 if ($self->{language_id}) {
3551 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3553 $output_dateformat = $::myconfig{dateformat};
3554 $output_numberformat = $::myconfig{numberformat};
3555 $output_longdates = 1;
3558 # Retrieve accounts for tax calculation.
3559 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3561 if ($self->{type} =~ /_delivery_order$/) {
3562 DO->order_details();
3563 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3564 OE->order_details(\%::myconfig, $self);
3566 IS->invoice_details(\%::myconfig, $self, $::locale);
3569 # Chose extension & set source file name
3570 my $extension = 'html';
3571 if ($self->{format} eq 'postscript') {
3572 $self->{postscript} = 1;
3574 } elsif ($self->{"format"} =~ /pdf/) {
3576 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3577 } elsif ($self->{"format"} =~ /opendocument/) {
3578 $self->{opendocument} = 1;
3580 } elsif ($self->{"format"} =~ /excel/) {
3585 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3586 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3587 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3590 $self->format_dates($output_dateformat, $output_longdates,
3591 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3592 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3593 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3595 $self->reformat_numbers($output_numberformat, 2,
3596 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3597 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3599 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3601 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3603 if (scalar @{ $cvar_date_fields }) {
3604 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3607 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3608 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3615 my ($self, $dateformat, $longformat, @indices) = @_;
3617 $dateformat ||= $::myconfig{dateformat};
3619 foreach my $idx (@indices) {
3620 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3621 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3622 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3626 next unless defined $self->{$idx};
3628 if (!ref($self->{$idx})) {
3629 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3631 } elsif (ref($self->{$idx}) eq "ARRAY") {
3632 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3633 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3639 sub reformat_numbers {
3640 my ($self, $numberformat, $places, @indices) = @_;
3642 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3644 foreach my $idx (@indices) {
3645 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3646 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3647 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3651 next unless defined $self->{$idx};
3653 if (!ref($self->{$idx})) {
3654 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3656 } elsif (ref($self->{$idx}) eq "ARRAY") {
3657 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3658 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3663 my $saved_numberformat = $::myconfig{numberformat};
3664 $::myconfig{numberformat} = $numberformat;
3666 foreach my $idx (@indices) {
3667 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3668 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3669 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3673 next unless defined $self->{$idx};
3675 if (!ref($self->{$idx})) {
3676 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3678 } elsif (ref($self->{$idx}) eq "ARRAY") {
3679 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3680 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3685 $::myconfig{numberformat} = $saved_numberformat;
3694 SL::Form.pm - main data object.
3698 This is the main data object of Lx-Office.
3699 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3700 Points of interest for a beginner are:
3702 - $form->error - renders a generic error in html. accepts an error message
3703 - $form->get_standard_dbh - returns a database connection for the
3705 =head1 SPECIAL FUNCTIONS
3707 =head2 C<_store_value()>
3709 parses a complex var name, and stores it in the form.
3712 $form->_store_value($key, $value);
3714 keys must start with a string, and can contain various tokens.
3715 supported key structures are:
3718 simple key strings work as expected
3723 separating two keys by a dot (.) will result in a hash lookup for the inner value
3724 this is similar to the behaviour of java and templating mechanisms.
3726 filter.description => $form->{filter}->{description}
3728 3. array+hashref access
3730 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3731 using [+] instead of [] will force a new array index. this is useful for recurring
3732 data structures like part lists. put a [+] into the first varname, and use [] on the
3735 repeating these names in your template:
3738 invoice.items[].parts_id
3742 $form->{invoice}->{items}->[
3756 using brackets at the end of a name will result in a pure array to be created.
3757 note that you mustn't use [+], which is reserved for array+hash access and will
3758 result in undefined behaviour in array context.
3760 filter.status[] => $form->{status}->[ val1, val2, ... ]
3762 =head2 C<update_business> PARAMS
3765 \%config, - config hashref
3766 $business_id, - business id
3767 $dbh - optional database handle
3769 handles business (thats customer/vendor types) sequences.
3771 special behaviour for empty strings in customerinitnumber field:
3772 will in this case not increase the value, and return undef.
3774 =head2 C<redirect_header> $url
3776 Generates a HTTP redirection header for the new C<$url>. Constructs an
3777 absolute URL including scheme, host name and port. If C<$url> is a
3778 relative URL then it is considered relative to Lx-Office base URL.
3780 This function C<die>s if headers have already been created with
3781 C<$::form-E<gt>header>.
3785 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3786 print $::form->redirect_header('http://www.lx-office.org/');
3790 Generates a general purpose http/html header and includes most of the scripts
3791 ans stylesheets needed.
3793 Only one header will be generated. If the method was already called in this
3794 request it will not output anything and return undef. Also if no
3795 HTTP_USER_AGENT is found, no header is generated.
3797 Although header does not accept parameters itself, it will honor special
3798 hashkeys of its Form instance:
3806 If one of these is set, a http-equiv refresh is generated. Missing parameters
3807 default to 3 seconds and the refering url.
3813 If these are arrayrefs the contents will be inlined into the header.
3817 If true, a css snippet will be generated that sets the page in landscape mode.
3821 Used to override the default favicon.
3825 A html page title will be generated from this