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;
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 = $::lx_office_conf{system}->{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 = $::lx_office_conf{system}->{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 = $::lx_office_conf{system}->{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"} = $::lx_office_conf{system}->{dbcharset};
806 $additional_params->{"conf_webdav"} = $::lx_office_conf{system}->{webdav};
807 $additional_params->{"conf_lizenzen"} = $::lx_office_conf{system}->{lizenzen};
808 $additional_params->{"conf_latex_templates"} = $::lx_office_conf{print_templates}->{latex};
809 $additional_params->{"conf_opendocument_templates"} = $::lx_office_conf{print_templates}->{opendocument};
810 $additional_params->{"conf_vertreter"} = $::lx_office_conf{system}->{vertreter};
811 $additional_params->{"conf_show_best_before"} = $::lx_office_conf{system}->{show_best_before};
812 $additional_params->{"conf_parts_image_css"} = $::lx_office_conf{features}->{parts_image_css};
813 $additional_params->{"conf_parts_listing_images"} = $::lx_office_conf{features}->{parts_listing_images};
814 $additional_params->{"conf_parts_show_image"} = $::lx_office_conf{features}->{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' => $::lx_office_conf{paths}->{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) = @_;
1199 my $userspath = $::lx_office_conf{paths}->{userspath};
1201 $self->{"cwd"} = getcwd();
1202 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1207 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1208 $template_type = 'OpenDocument';
1209 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1211 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1212 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1213 $template_type = 'LaTeX';
1214 $ext_for_format = 'pdf';
1216 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1217 $template_type = 'HTML';
1218 $ext_for_format = 'html';
1220 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1221 $template_type = 'XML';
1222 $ext_for_format = 'xml';
1224 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1225 $template_type = 'XML';
1227 } elsif ( $self->{"format"} =~ /excel/i ) {
1228 $template_type = 'Excel';
1229 $ext_for_format = 'xls';
1231 } elsif ( defined $self->{'format'}) {
1232 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1234 } elsif ( $self->{'format'} eq '' ) {
1235 $self->error("No Outputformat given: $self->{'format'}");
1237 } else { #Catch the rest
1238 $self->error("Outputformat not defined: $self->{'format'}");
1241 my $template = SL::Template::create(type => $template_type,
1242 file_name => $self->{IN},
1244 myconfig => $myconfig,
1245 userspath => $userspath);
1247 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1248 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1250 if (!$self->{employee_id}) {
1251 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1254 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1256 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1258 # OUT is used for the media, screen, printer, email
1259 # for postscript we store a copy in a temporary file
1261 my $prepend_userspath;
1263 if (!$self->{tmpfile}) {
1264 $self->{tmpfile} = "${fileid}.$self->{IN}";
1265 $prepend_userspath = 1;
1268 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1270 $self->{tmpfile} =~ s|.*/||;
1271 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1272 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1274 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1275 $out = $self->{OUT};
1276 $self->{OUT} = ">$self->{tmpfile}";
1282 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1283 $result = $template->parse(*OUT);
1288 $result = $template->parse(*STDOUT);
1293 $self->error("$self->{IN} : " . $template->get_error());
1296 if ($self->{media} eq 'file') {
1297 copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1299 chdir("$self->{cwd}");
1301 $::lxdebug->leave_sub();
1306 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1308 if ($self->{media} eq 'email') {
1310 my $mail = new Mailer;
1312 map { $mail->{$_} = $self->{$_} }
1313 qw(cc bcc subject message version format);
1314 $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1315 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1316 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1317 $mail->{fileid} = "$fileid.";
1318 $myconfig->{signature} =~ s/\r//g;
1320 # if we send html or plain text inline
1321 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1322 $mail->{contenttype} = "text/html";
1324 $mail->{message} =~ s/\r//g;
1325 $mail->{message} =~ s/\n/<br>\n/g;
1326 $myconfig->{signature} =~ s/\n/<br>\n/g;
1327 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1329 open(IN, $self->{tmpfile})
1330 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1332 $mail->{message} .= $_;
1339 if (!$self->{"do_not_attach"}) {
1340 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1341 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1342 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1343 "name" => $attachment_name }];
1346 $mail->{message} =~ s/\r//g;
1347 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1351 my $err = $mail->send();
1352 $self->error($self->cleanup . "$err") if ($err);
1356 $self->{OUT} = $out;
1358 my $numbytes = (-s $self->{tmpfile});
1359 open(IN, $self->{tmpfile})
1360 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1362 $self->{copies} = 1 unless $self->{media} eq 'printer';
1364 chdir("$self->{cwd}");
1365 #print(STDERR "Kopien $self->{copies}\n");
1366 #print(STDERR "OUT $self->{OUT}\n");
1367 for my $i (1 .. $self->{copies}) {
1369 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1370 print OUT while <IN>;
1375 $self->{attachment_filename} = ($self->{attachment_filename})
1376 ? $self->{attachment_filename}
1377 : $self->generate_attachment_filename();
1379 # launch application
1380 print qq|Content-Type: | . $template->get_mime_type() . qq|
1381 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1382 Content-Length: $numbytes
1386 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1397 chdir("$self->{cwd}");
1398 $main::lxdebug->leave_sub();
1401 sub get_formname_translation {
1402 $main::lxdebug->enter_sub();
1403 my ($self, $formname) = @_;
1405 $formname ||= $self->{formname};
1407 my %formname_translations = (
1408 bin_list => $main::locale->text('Bin List'),
1409 credit_note => $main::locale->text('Credit Note'),
1410 invoice => $main::locale->text('Invoice'),
1411 pick_list => $main::locale->text('Pick List'),
1412 proforma => $main::locale->text('Proforma Invoice'),
1413 purchase_order => $main::locale->text('Purchase Order'),
1414 request_quotation => $main::locale->text('RFQ'),
1415 sales_order => $main::locale->text('Confirmation'),
1416 sales_quotation => $main::locale->text('Quotation'),
1417 storno_invoice => $main::locale->text('Storno Invoice'),
1418 sales_delivery_order => $main::locale->text('Delivery Order'),
1419 purchase_delivery_order => $main::locale->text('Delivery Order'),
1420 dunning => $main::locale->text('Dunning'),
1423 $main::lxdebug->leave_sub();
1424 return $formname_translations{$formname}
1427 sub get_number_prefix_for_type {
1428 $main::lxdebug->enter_sub();
1432 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1433 : ($self->{type} =~ /_quotation$/) ? 'quo'
1434 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1437 $main::lxdebug->leave_sub();
1441 sub get_extension_for_format {
1442 $main::lxdebug->enter_sub();
1445 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1446 : $self->{format} =~ /postscript/i ? ".ps"
1447 : $self->{format} =~ /opendocument/i ? ".odt"
1448 : $self->{format} =~ /excel/i ? ".xls"
1449 : $self->{format} =~ /html/i ? ".html"
1452 $main::lxdebug->leave_sub();
1456 sub generate_attachment_filename {
1457 $main::lxdebug->enter_sub();
1460 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1461 my $prefix = $self->get_number_prefix_for_type();
1463 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1464 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1466 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1467 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1470 $attachment_filename = "";
1473 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1474 $attachment_filename =~ s|[\s/\\]+|_|g;
1476 $main::lxdebug->leave_sub();
1477 return $attachment_filename;
1480 sub generate_email_subject {
1481 $main::lxdebug->enter_sub();
1484 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1485 my $prefix = $self->get_number_prefix_for_type();
1487 if ($subject && $self->{"${prefix}number"}) {
1488 $subject .= " " . $self->{"${prefix}number"}
1491 $main::lxdebug->leave_sub();
1496 $main::lxdebug->enter_sub();
1500 chdir("$self->{tmpdir}");
1503 if (-f "$self->{tmpfile}.err") {
1504 open(FH, "$self->{tmpfile}.err");
1509 if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1510 $self->{tmpfile} =~ s|.*/||g;
1512 $self->{tmpfile} =~ s/\.\w+$//g;
1513 my $tmpfile = $self->{tmpfile};
1514 unlink(<$tmpfile.*>);
1517 chdir("$self->{cwd}");
1519 $main::lxdebug->leave_sub();
1525 $main::lxdebug->enter_sub();
1527 my ($self, $date, $myconfig) = @_;
1530 if ($date && $date =~ /\D/) {
1532 if ($myconfig->{dateformat} =~ /^yy/) {
1533 ($yy, $mm, $dd) = split /\D/, $date;
1535 if ($myconfig->{dateformat} =~ /^mm/) {
1536 ($mm, $dd, $yy) = split /\D/, $date;
1538 if ($myconfig->{dateformat} =~ /^dd/) {
1539 ($dd, $mm, $yy) = split /\D/, $date;
1544 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1545 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1547 $dd = "0$dd" if ($dd < 10);
1548 $mm = "0$mm" if ($mm < 10);
1550 $date = "$yy$mm$dd";
1553 $main::lxdebug->leave_sub();
1558 # Database routines used throughout
1560 sub _dbconnect_options {
1562 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1569 $main::lxdebug->enter_sub(2);
1571 my ($self, $myconfig) = @_;
1573 # connect to database
1574 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1578 if ($myconfig->{dboptions}) {
1579 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1582 $main::lxdebug->leave_sub(2);
1587 sub dbconnect_noauto {
1588 $main::lxdebug->enter_sub();
1590 my ($self, $myconfig) = @_;
1592 # connect to database
1593 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1597 if ($myconfig->{dboptions}) {
1598 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1601 $main::lxdebug->leave_sub();
1606 sub get_standard_dbh {
1607 $main::lxdebug->enter_sub(2);
1610 my $myconfig = shift || \%::myconfig;
1612 if ($standard_dbh && !$standard_dbh->{Active}) {
1613 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1614 undef $standard_dbh;
1617 $standard_dbh ||= SL::DB::create->dbh;
1619 $main::lxdebug->leave_sub(2);
1621 return $standard_dbh;
1625 $main::lxdebug->enter_sub();
1627 my ($self, $date, $myconfig) = @_;
1628 my $dbh = $self->dbconnect($myconfig);
1630 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1631 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1632 my ($closed) = $sth->fetchrow_array;
1634 $main::lxdebug->leave_sub();
1639 sub update_balance {
1640 $main::lxdebug->enter_sub();
1642 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1644 # if we have a value, go do it
1647 # retrieve balance from table
1648 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1649 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1650 my ($balance) = $sth->fetchrow_array;
1656 $query = "UPDATE $table SET $field = $balance WHERE $where";
1657 do_query($self, $dbh, $query, @values);
1659 $main::lxdebug->leave_sub();
1662 sub update_exchangerate {
1663 $main::lxdebug->enter_sub();
1665 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1667 # some sanity check for currency
1669 $main::lxdebug->leave_sub();
1672 $query = qq|SELECT curr FROM defaults|;
1674 my ($currency) = selectrow_query($self, $dbh, $query);
1675 my ($defaultcurrency) = split m/:/, $currency;
1678 if ($curr eq $defaultcurrency) {
1679 $main::lxdebug->leave_sub();
1683 $query = qq|SELECT e.curr FROM exchangerate e
1684 WHERE e.curr = ? AND e.transdate = ?
1686 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1695 $buy = conv_i($buy, "NULL");
1696 $sell = conv_i($sell, "NULL");
1699 if ($buy != 0 && $sell != 0) {
1700 $set = "buy = $buy, sell = $sell";
1701 } elsif ($buy != 0) {
1702 $set = "buy = $buy";
1703 } elsif ($sell != 0) {
1704 $set = "sell = $sell";
1707 if ($sth->fetchrow_array) {
1708 $query = qq|UPDATE exchangerate
1714 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1715 VALUES (?, $buy, $sell, ?)|;
1718 do_query($self, $dbh, $query, $curr, $transdate);
1720 $main::lxdebug->leave_sub();
1723 sub save_exchangerate {
1724 $main::lxdebug->enter_sub();
1726 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1728 my $dbh = $self->dbconnect($myconfig);
1732 $buy = $rate if $fld eq 'buy';
1733 $sell = $rate if $fld eq 'sell';
1736 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1741 $main::lxdebug->leave_sub();
1744 sub get_exchangerate {
1745 $main::lxdebug->enter_sub();
1747 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1750 unless ($transdate) {
1751 $main::lxdebug->leave_sub();
1755 $query = qq|SELECT curr FROM defaults|;
1757 my ($currency) = selectrow_query($self, $dbh, $query);
1758 my ($defaultcurrency) = split m/:/, $currency;
1760 if ($currency eq $defaultcurrency) {
1761 $main::lxdebug->leave_sub();
1765 $query = qq|SELECT e.$fld FROM exchangerate e
1766 WHERE e.curr = ? AND e.transdate = ?|;
1767 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1771 $main::lxdebug->leave_sub();
1773 return $exchangerate;
1776 sub check_exchangerate {
1777 $main::lxdebug->enter_sub();
1779 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1781 if ($fld !~/^buy|sell$/) {
1782 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1785 unless ($transdate) {
1786 $main::lxdebug->leave_sub();
1790 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1792 if ($currency eq $defaultcurrency) {
1793 $main::lxdebug->leave_sub();
1797 my $dbh = $self->get_standard_dbh($myconfig);
1798 my $query = qq|SELECT e.$fld FROM exchangerate e
1799 WHERE e.curr = ? AND e.transdate = ?|;
1801 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1803 $main::lxdebug->leave_sub();
1805 return $exchangerate;
1808 sub get_all_currencies {
1809 $main::lxdebug->enter_sub();
1812 my $myconfig = shift || \%::myconfig;
1813 my $dbh = $self->get_standard_dbh($myconfig);
1815 my $query = qq|SELECT curr FROM defaults|;
1817 my ($curr) = selectrow_query($self, $dbh, $query);
1818 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1820 $main::lxdebug->leave_sub();
1825 sub get_default_currency {
1826 $main::lxdebug->enter_sub();
1828 my ($self, $myconfig) = @_;
1829 my @currencies = $self->get_all_currencies($myconfig);
1831 $main::lxdebug->leave_sub();
1833 return $currencies[0];
1836 sub set_payment_options {
1837 $main::lxdebug->enter_sub();
1839 my ($self, $myconfig, $transdate) = @_;
1841 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1843 my $dbh = $self->get_standard_dbh($myconfig);
1846 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1847 qq|FROM payment_terms p | .
1850 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1851 $self->{payment_terms}) =
1852 selectrow_query($self, $dbh, $query, $self->{payment_id});
1854 if ($transdate eq "") {
1855 if ($self->{invdate}) {
1856 $transdate = $self->{invdate};
1858 $transdate = $self->{transdate};
1863 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1864 qq|FROM payment_terms|;
1865 ($self->{netto_date}, $self->{skonto_date}) =
1866 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1868 my ($invtotal, $total);
1869 my (%amounts, %formatted_amounts);
1871 if ($self->{type} =~ /_order$/) {
1872 $amounts{invtotal} = $self->{ordtotal};
1873 $amounts{total} = $self->{ordtotal};
1875 } elsif ($self->{type} =~ /_quotation$/) {
1876 $amounts{invtotal} = $self->{quototal};
1877 $amounts{total} = $self->{quototal};
1880 $amounts{invtotal} = $self->{invtotal};
1881 $amounts{total} = $self->{total};
1883 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1885 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1887 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1888 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1889 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1891 foreach (keys %amounts) {
1892 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1893 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1896 if ($self->{"language_id"}) {
1898 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1899 qq|FROM translation_payment_terms t | .
1900 qq|LEFT JOIN language l ON t.language_id = l.id | .
1901 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1902 my ($description_long, $output_numberformat, $output_dateformat,
1903 $output_longdates) =
1904 selectrow_query($self, $dbh, $query,
1905 $self->{"language_id"}, $self->{"payment_id"});
1907 $self->{payment_terms} = $description_long if ($description_long);
1909 if ($output_dateformat) {
1910 foreach my $key (qw(netto_date skonto_date)) {
1912 $main::locale->reformat_date($myconfig, $self->{$key},
1918 if ($output_numberformat &&
1919 ($output_numberformat ne $myconfig->{"numberformat"})) {
1920 my $saved_numberformat = $myconfig->{"numberformat"};
1921 $myconfig->{"numberformat"} = $output_numberformat;
1922 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1923 $myconfig->{"numberformat"} = $saved_numberformat;
1927 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1928 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1929 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1930 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1931 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1932 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1933 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1935 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1937 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1939 $main::lxdebug->leave_sub();
1943 sub get_template_language {
1944 $main::lxdebug->enter_sub();
1946 my ($self, $myconfig) = @_;
1948 my $template_code = "";
1950 if ($self->{language_id}) {
1951 my $dbh = $self->get_standard_dbh($myconfig);
1952 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1953 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1956 $main::lxdebug->leave_sub();
1958 return $template_code;
1961 sub get_printer_code {
1962 $main::lxdebug->enter_sub();
1964 my ($self, $myconfig) = @_;
1966 my $template_code = "";
1968 if ($self->{printer_id}) {
1969 my $dbh = $self->get_standard_dbh($myconfig);
1970 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1971 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1974 $main::lxdebug->leave_sub();
1976 return $template_code;
1980 $main::lxdebug->enter_sub();
1982 my ($self, $myconfig) = @_;
1984 my $template_code = "";
1986 if ($self->{shipto_id}) {
1987 my $dbh = $self->get_standard_dbh($myconfig);
1988 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1989 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1990 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1993 $main::lxdebug->leave_sub();
1997 $main::lxdebug->enter_sub();
1999 my ($self, $dbh, $id, $module) = @_;
2004 foreach my $item (qw(name department_1 department_2 street zipcode city country
2005 contact cp_gender phone fax email)) {
2006 if ($self->{"shipto$item"}) {
2007 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2009 push(@values, $self->{"shipto${item}"});
2013 if ($self->{shipto_id}) {
2014 my $query = qq|UPDATE shipto set
2016 shiptodepartment_1 = ?,
2017 shiptodepartment_2 = ?,
2023 shiptocp_gender = ?,
2027 WHERE shipto_id = ?|;
2028 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2030 my $query = qq|SELECT * FROM shipto
2031 WHERE shiptoname = ? AND
2032 shiptodepartment_1 = ? AND
2033 shiptodepartment_2 = ? AND
2034 shiptostreet = ? AND
2035 shiptozipcode = ? AND
2037 shiptocountry = ? AND
2038 shiptocontact = ? AND
2039 shiptocp_gender = ? AND
2045 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2048 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2049 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2050 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2051 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2052 do_query($self, $dbh, $query, $id, @values, $module);
2057 $main::lxdebug->leave_sub();
2061 $main::lxdebug->enter_sub();
2063 my ($self, $dbh) = @_;
2065 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2067 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2068 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2069 $self->{"employee_id"} *= 1;
2071 $main::lxdebug->leave_sub();
2074 sub get_employee_data {
2075 $main::lxdebug->enter_sub();
2080 Common::check_params(\%params, qw(prefix));
2081 Common::check_params_x(\%params, qw(id));
2084 $main::lxdebug->leave_sub();
2088 my $myconfig = \%main::myconfig;
2089 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2091 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2094 my $user = User->new($login);
2095 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2097 $self->{$params{prefix} . '_login'} = $login;
2098 $self->{$params{prefix} . '_name'} ||= $login;
2101 $main::lxdebug->leave_sub();
2105 $main::lxdebug->enter_sub();
2107 my ($self, $myconfig, $reference_date) = @_;
2109 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2111 my $dbh = $self->get_standard_dbh($myconfig);
2112 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2113 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2115 $main::lxdebug->leave_sub();
2121 $main::lxdebug->enter_sub();
2123 my ($self, $dbh, $id, $key) = @_;
2125 $key = "all_contacts" unless ($key);
2129 $main::lxdebug->leave_sub();
2134 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2135 qq|FROM contacts | .
2136 qq|WHERE cp_cv_id = ? | .
2137 qq|ORDER BY lower(cp_name)|;
2139 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2141 $main::lxdebug->leave_sub();
2145 $main::lxdebug->enter_sub();
2147 my ($self, $dbh, $key) = @_;
2149 my ($all, $old_id, $where, @values);
2151 if (ref($key) eq "HASH") {
2154 $key = "ALL_PROJECTS";
2156 foreach my $p (keys(%{$params})) {
2158 $all = $params->{$p};
2159 } elsif ($p eq "old_id") {
2160 $old_id = $params->{$p};
2161 } elsif ($p eq "key") {
2162 $key = $params->{$p};
2168 $where = "WHERE active ";
2170 if (ref($old_id) eq "ARRAY") {
2171 my @ids = grep({ $_ } @{$old_id});
2173 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2174 push(@values, @ids);
2177 $where .= " OR (id = ?) ";
2178 push(@values, $old_id);
2184 qq|SELECT id, projectnumber, description, active | .
2187 qq|ORDER BY lower(projectnumber)|;
2189 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2191 $main::lxdebug->leave_sub();
2195 $main::lxdebug->enter_sub();
2197 my ($self, $dbh, $vc_id, $key) = @_;
2199 $key = "all_shipto" unless ($key);
2202 # get shipping addresses
2203 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2205 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2211 $main::lxdebug->leave_sub();
2215 $main::lxdebug->enter_sub();
2217 my ($self, $dbh, $key) = @_;
2219 $key = "all_printers" unless ($key);
2221 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2223 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2225 $main::lxdebug->leave_sub();
2229 $main::lxdebug->enter_sub();
2231 my ($self, $dbh, $params) = @_;
2234 $key = $params->{key};
2235 $key = "all_charts" unless ($key);
2237 my $transdate = quote_db_date($params->{transdate});
2240 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2242 qq|LEFT JOIN taxkeys tk ON | .
2243 qq|(tk.id = (SELECT id FROM taxkeys | .
2244 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2245 qq| ORDER BY startdate DESC LIMIT 1)) | .
2246 qq|ORDER BY c.accno|;
2248 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2250 $main::lxdebug->leave_sub();
2253 sub _get_taxcharts {
2254 $main::lxdebug->enter_sub();
2256 my ($self, $dbh, $params) = @_;
2258 my $key = "all_taxcharts";
2261 if (ref $params eq 'HASH') {
2262 $key = $params->{key} if ($params->{key});
2263 if ($params->{module} eq 'AR') {
2264 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2266 } elsif ($params->{module} eq 'AP') {
2267 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2274 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2276 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2278 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2280 $main::lxdebug->leave_sub();
2284 $main::lxdebug->enter_sub();
2286 my ($self, $dbh, $key) = @_;
2288 $key = "all_taxzones" unless ($key);
2290 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2292 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2294 $main::lxdebug->leave_sub();
2297 sub _get_employees {
2298 $main::lxdebug->enter_sub();
2300 my ($self, $dbh, $default_key, $key) = @_;
2302 $key = $default_key unless ($key);
2303 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2305 $main::lxdebug->leave_sub();
2308 sub _get_business_types {
2309 $main::lxdebug->enter_sub();
2311 my ($self, $dbh, $key) = @_;
2313 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2314 $options->{key} ||= "all_business_types";
2317 if (exists $options->{salesman}) {
2318 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2321 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2323 $main::lxdebug->leave_sub();
2326 sub _get_languages {
2327 $main::lxdebug->enter_sub();
2329 my ($self, $dbh, $key) = @_;
2331 $key = "all_languages" unless ($key);
2333 my $query = qq|SELECT * FROM language ORDER BY id|;
2335 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2337 $main::lxdebug->leave_sub();
2340 sub _get_dunning_configs {
2341 $main::lxdebug->enter_sub();
2343 my ($self, $dbh, $key) = @_;
2345 $key = "all_dunning_configs" unless ($key);
2347 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2349 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2351 $main::lxdebug->leave_sub();
2354 sub _get_currencies {
2355 $main::lxdebug->enter_sub();
2357 my ($self, $dbh, $key) = @_;
2359 $key = "all_currencies" unless ($key);
2361 my $query = qq|SELECT curr AS currency FROM defaults|;
2363 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2365 $main::lxdebug->leave_sub();
2369 $main::lxdebug->enter_sub();
2371 my ($self, $dbh, $key) = @_;
2373 $key = "all_payments" unless ($key);
2375 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2377 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2379 $main::lxdebug->leave_sub();
2382 sub _get_customers {
2383 $main::lxdebug->enter_sub();
2385 my ($self, $dbh, $key) = @_;
2387 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2388 $options->{key} ||= "all_customers";
2389 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2392 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2393 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2394 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2396 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2397 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2399 $main::lxdebug->leave_sub();
2403 $main::lxdebug->enter_sub();
2405 my ($self, $dbh, $key) = @_;
2407 $key = "all_vendors" unless ($key);
2409 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2411 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2413 $main::lxdebug->leave_sub();
2416 sub _get_departments {
2417 $main::lxdebug->enter_sub();
2419 my ($self, $dbh, $key) = @_;
2421 $key = "all_departments" unless ($key);
2423 my $query = qq|SELECT * FROM department ORDER BY description|;
2425 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2427 $main::lxdebug->leave_sub();
2430 sub _get_warehouses {
2431 $main::lxdebug->enter_sub();
2433 my ($self, $dbh, $param) = @_;
2435 my ($key, $bins_key);
2437 if ('' eq ref $param) {
2441 $key = $param->{key};
2442 $bins_key = $param->{bins};
2445 my $query = qq|SELECT w.* FROM warehouse w
2446 WHERE (NOT w.invalid) AND
2447 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2448 ORDER BY w.sortkey|;
2450 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2453 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2454 my $sth = prepare_query($self, $dbh, $query);
2456 foreach my $warehouse (@{ $self->{$key} }) {
2457 do_statement($self, $sth, $query, $warehouse->{id});
2458 $warehouse->{$bins_key} = [];
2460 while (my $ref = $sth->fetchrow_hashref()) {
2461 push @{ $warehouse->{$bins_key} }, $ref;
2467 $main::lxdebug->leave_sub();
2471 $main::lxdebug->enter_sub();
2473 my ($self, $dbh, $table, $key, $sortkey) = @_;
2475 my $query = qq|SELECT * FROM $table|;
2476 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2478 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2480 $main::lxdebug->leave_sub();
2484 # $main::lxdebug->enter_sub();
2486 # my ($self, $dbh, $key) = @_;
2488 # $key ||= "all_groups";
2490 # my $groups = $main::auth->read_groups();
2492 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2494 # $main::lxdebug->leave_sub();
2498 $main::lxdebug->enter_sub();
2503 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2504 my ($sth, $query, $ref);
2506 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2507 my $vc_id = $self->{"${vc}_id"};
2509 if ($params{"contacts"}) {
2510 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2513 if ($params{"shipto"}) {
2514 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2517 if ($params{"projects"} || $params{"all_projects"}) {
2518 $self->_get_projects($dbh, $params{"all_projects"} ?
2519 $params{"all_projects"} : $params{"projects"},
2520 $params{"all_projects"} ? 1 : 0);
2523 if ($params{"printers"}) {
2524 $self->_get_printers($dbh, $params{"printers"});
2527 if ($params{"languages"}) {
2528 $self->_get_languages($dbh, $params{"languages"});
2531 if ($params{"charts"}) {
2532 $self->_get_charts($dbh, $params{"charts"});
2535 if ($params{"taxcharts"}) {
2536 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2539 if ($params{"taxzones"}) {
2540 $self->_get_taxzones($dbh, $params{"taxzones"});
2543 if ($params{"employees"}) {
2544 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2547 if ($params{"salesmen"}) {
2548 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2551 if ($params{"business_types"}) {
2552 $self->_get_business_types($dbh, $params{"business_types"});
2555 if ($params{"dunning_configs"}) {
2556 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2559 if($params{"currencies"}) {
2560 $self->_get_currencies($dbh, $params{"currencies"});
2563 if($params{"customers"}) {
2564 $self->_get_customers($dbh, $params{"customers"});
2567 if($params{"vendors"}) {
2568 if (ref $params{"vendors"} eq 'HASH') {
2569 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2571 $self->_get_vendors($dbh, $params{"vendors"});
2575 if($params{"payments"}) {
2576 $self->_get_payments($dbh, $params{"payments"});
2579 if($params{"departments"}) {
2580 $self->_get_departments($dbh, $params{"departments"});
2583 if ($params{price_factors}) {
2584 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2587 if ($params{warehouses}) {
2588 $self->_get_warehouses($dbh, $params{warehouses});
2591 # if ($params{groups}) {
2592 # $self->_get_groups($dbh, $params{groups});
2595 if ($params{partsgroup}) {
2596 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2599 $main::lxdebug->leave_sub();
2602 # this sub gets the id and name from $table
2604 $main::lxdebug->enter_sub();
2606 my ($self, $myconfig, $table) = @_;
2608 # connect to database
2609 my $dbh = $self->get_standard_dbh($myconfig);
2611 $table = $table eq "customer" ? "customer" : "vendor";
2612 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2614 my ($query, @values);
2616 if (!$self->{openinvoices}) {
2618 if ($self->{customernumber} ne "") {
2619 $where = qq|(vc.customernumber ILIKE ?)|;
2620 push(@values, '%' . $self->{customernumber} . '%');
2622 $where = qq|(vc.name ILIKE ?)|;
2623 push(@values, '%' . $self->{$table} . '%');
2627 qq~SELECT vc.id, vc.name,
2628 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2630 WHERE $where AND (NOT vc.obsolete)
2634 qq~SELECT DISTINCT vc.id, vc.name,
2635 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2637 JOIN $table vc ON (a.${table}_id = vc.id)
2638 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2640 push(@values, '%' . $self->{$table} . '%');
2643 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2645 $main::lxdebug->leave_sub();
2647 return scalar(@{ $self->{name_list} });
2650 # the selection sub is used in the AR, AP, IS, IR and OE module
2653 $main::lxdebug->enter_sub();
2655 my ($self, $myconfig, $table, $module) = @_;
2658 my $dbh = $self->get_standard_dbh;
2660 $table = $table eq "customer" ? "customer" : "vendor";
2662 my $query = qq|SELECT count(*) FROM $table|;
2663 my ($count) = selectrow_query($self, $dbh, $query);
2665 # build selection list
2666 if ($count <= $myconfig->{vclimit}) {
2667 $query = qq|SELECT id, name, salesman_id
2668 FROM $table WHERE NOT obsolete
2670 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2674 $self->get_employee($dbh);
2676 # setup sales contacts
2677 $query = qq|SELECT e.id, e.name
2679 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2680 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2683 push(@{ $self->{all_employees} },
2684 { id => $self->{employee_id},
2685 name => $self->{employee} });
2687 # sort the whole thing
2688 @{ $self->{all_employees} } =
2689 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2691 if ($module eq 'AR') {
2693 # prepare query for departments
2694 $query = qq|SELECT id, description
2697 ORDER BY description|;
2700 $query = qq|SELECT id, description
2702 ORDER BY description|;
2705 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2708 $query = qq|SELECT id, description
2712 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2715 $query = qq|SELECT printer_description, id
2717 ORDER BY printer_description|;
2719 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2722 $query = qq|SELECT id, description
2726 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2728 $main::lxdebug->leave_sub();
2731 sub language_payment {
2732 $main::lxdebug->enter_sub();
2734 my ($self, $myconfig) = @_;
2736 my $dbh = $self->get_standard_dbh($myconfig);
2738 my $query = qq|SELECT id, description
2742 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2745 $query = qq|SELECT printer_description, id
2747 ORDER BY printer_description|;
2749 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2752 $query = qq|SELECT id, description
2756 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2758 # get buchungsgruppen
2759 $query = qq|SELECT id, description
2760 FROM buchungsgruppen|;
2762 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2764 $main::lxdebug->leave_sub();
2767 # this is only used for reports
2768 sub all_departments {
2769 $main::lxdebug->enter_sub();
2771 my ($self, $myconfig, $table) = @_;
2773 my $dbh = $self->get_standard_dbh($myconfig);
2776 if ($table eq 'customer') {
2777 $where = "WHERE role = 'P' ";
2780 my $query = qq|SELECT id, description
2783 ORDER BY description|;
2784 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2786 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2788 $main::lxdebug->leave_sub();
2792 $main::lxdebug->enter_sub();
2794 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2797 if ($table eq "customer") {
2806 $self->all_vc($myconfig, $table, $module);
2808 # get last customers or vendors
2809 my ($query, $sth, $ref);
2811 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2816 my $transdate = "current_date";
2817 if ($self->{transdate}) {
2818 $transdate = $dbh->quote($self->{transdate});
2821 # now get the account numbers
2822 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2823 FROM chart c, taxkeys tk
2824 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2825 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2828 $sth = $dbh->prepare($query);
2830 do_statement($self, $sth, $query, '%' . $module . '%');
2832 $self->{accounts} = "";
2833 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2835 foreach my $key (split(/:/, $ref->{link})) {
2836 if ($key =~ /\Q$module\E/) {
2838 # cross reference for keys
2839 $xkeyref{ $ref->{accno} } = $key;
2841 push @{ $self->{"${module}_links"}{$key} },
2842 { accno => $ref->{accno},
2843 description => $ref->{description},
2844 taxkey => $ref->{taxkey_id},
2845 tax_id => $ref->{tax_id} };
2847 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2853 # get taxkeys and description
2854 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2855 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2857 if (($module eq "AP") || ($module eq "AR")) {
2858 # get tax rates and description
2859 $query = qq|SELECT * FROM tax|;
2860 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2866 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2867 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2868 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2869 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2871 d.description AS department,
2874 JOIN $table c ON (a.${table}_id = c.id)
2875 LEFT JOIN employee e ON (e.id = a.employee_id)
2876 LEFT JOIN department d ON (d.id = a.department_id)
2878 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2880 foreach my $key (keys %$ref) {
2881 $self->{$key} = $ref->{$key};
2884 my $transdate = "current_date";
2885 if ($self->{transdate}) {
2886 $transdate = $dbh->quote($self->{transdate});
2889 # now get the account numbers
2890 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2892 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2894 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2895 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2898 $sth = $dbh->prepare($query);
2899 do_statement($self, $sth, $query, "%$module%");
2901 $self->{accounts} = "";
2902 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2904 foreach my $key (split(/:/, $ref->{link})) {
2905 if ($key =~ /\Q$module\E/) {
2907 # cross reference for keys
2908 $xkeyref{ $ref->{accno} } = $key;
2910 push @{ $self->{"${module}_links"}{$key} },
2911 { accno => $ref->{accno},
2912 description => $ref->{description},
2913 taxkey => $ref->{taxkey_id},
2914 tax_id => $ref->{tax_id} };
2916 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2922 # get amounts from individual entries
2925 c.accno, c.description,
2926 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2930 LEFT JOIN chart c ON (c.id = a.chart_id)
2931 LEFT JOIN project p ON (p.id = a.project_id)
2932 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2933 WHERE (tk.taxkey_id=a.taxkey) AND
2934 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2935 THEN tk.chart_id = a.chart_id
2938 OR (c.link='%tax%')) AND
2939 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2940 WHERE a.trans_id = ?
2941 AND a.fx_transaction = '0'
2942 ORDER BY a.acc_trans_id, a.transdate|;
2943 $sth = $dbh->prepare($query);
2944 do_statement($self, $sth, $query, $self->{id});
2946 # get exchangerate for currency
2947 $self->{exchangerate} =
2948 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2951 # store amounts in {acc_trans}{$key} for multiple accounts
2952 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2953 $ref->{exchangerate} =
2954 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2955 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2958 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2959 $ref->{amount} *= -1;
2961 $ref->{index} = $index;
2963 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2969 d.curr AS currencies, d.closedto, d.revtrans,
2970 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2971 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2973 $ref = selectfirst_hashref_query($self, $dbh, $query);
2974 map { $self->{$_} = $ref->{$_} } keys %$ref;
2981 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2982 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2983 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2985 $ref = selectfirst_hashref_query($self, $dbh, $query);
2986 map { $self->{$_} = $ref->{$_} } keys %$ref;
2988 if ($self->{"$self->{vc}_id"}) {
2990 # only setup currency
2991 ($self->{currency}) = split(/:/, $self->{currencies});
2995 $self->lastname_used($dbh, $myconfig, $table, $module);
2997 # get exchangerate for currency
2998 $self->{exchangerate} =
2999 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3005 $main::lxdebug->leave_sub();
3009 $main::lxdebug->enter_sub();
3011 my ($self, $dbh, $myconfig, $table, $module) = @_;
3015 $table = $table eq "customer" ? "customer" : "vendor";
3016 my %column_map = ("a.curr" => "currency",
3017 "a.${table}_id" => "${table}_id",
3018 "a.department_id" => "department_id",
3019 "d.description" => "department",
3020 "ct.name" => $table,
3021 "current_date + ct.terms" => "duedate",
3024 if ($self->{type} =~ /delivery_order/) {
3025 $arap = 'delivery_orders';
3026 delete $column_map{"a.curr"};
3028 } elsif ($self->{type} =~ /_order/) {
3030 $where = "quotation = '0'";
3032 } elsif ($self->{type} =~ /_quotation/) {
3034 $where = "quotation = '1'";
3036 } elsif ($table eq 'customer') {
3044 $where = "($where) AND" if ($where);
3045 my $query = qq|SELECT MAX(id) FROM $arap
3046 WHERE $where ${table}_id > 0|;
3047 my ($trans_id) = selectrow_query($self, $dbh, $query);
3050 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3051 $query = qq|SELECT $column_spec
3053 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3054 LEFT JOIN department d ON (a.department_id = d.id)
3056 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3058 map { $self->{$_} = $ref->{$_} } values %column_map;
3060 $main::lxdebug->leave_sub();
3064 $main::lxdebug->enter_sub();
3067 my $myconfig = shift || \%::myconfig;
3068 my ($thisdate, $days) = @_;
3070 my $dbh = $self->get_standard_dbh($myconfig);
3075 my $dateformat = $myconfig->{dateformat};
3076 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3077 $thisdate = $dbh->quote($thisdate);
3078 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3080 $query = qq|SELECT current_date AS thisdate|;
3083 ($thisdate) = selectrow_query($self, $dbh, $query);
3085 $main::lxdebug->leave_sub();
3091 $main::lxdebug->enter_sub();
3093 my ($self, $string) = @_;
3095 if ($string !~ /%/) {
3096 $string = "%$string%";
3099 $string =~ s/\'/\'\'/g;
3101 $main::lxdebug->leave_sub();
3107 $main::lxdebug->enter_sub();
3109 my ($self, $flds, $new, $count, $numrows) = @_;
3113 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3118 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3120 my $j = $item->{ndx} - 1;
3121 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3125 for $i ($count + 1 .. $numrows) {
3126 map { delete $self->{"${_}_$i"} } @{$flds};
3129 $main::lxdebug->leave_sub();
3133 $main::lxdebug->enter_sub();
3135 my ($self, $myconfig) = @_;
3139 my $dbh = $self->dbconnect_noauto($myconfig);
3141 my $query = qq|DELETE FROM status
3142 WHERE (formname = ?) AND (trans_id = ?)|;
3143 my $sth = prepare_query($self, $dbh, $query);
3145 if ($self->{formname} =~ /(check|receipt)/) {
3146 for $i (1 .. $self->{rowcount}) {
3147 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3150 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3154 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3155 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3157 my %queued = split / /, $self->{queued};
3160 if ($self->{formname} =~ /(check|receipt)/) {
3162 # this is a check or receipt, add one entry for each lineitem
3163 my ($accno) = split /--/, $self->{account};
3164 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3165 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3166 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3167 $sth = prepare_query($self, $dbh, $query);
3169 for $i (1 .. $self->{rowcount}) {
3170 if ($self->{"checked_$i"}) {
3171 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3177 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3178 VALUES (?, ?, ?, ?, ?)|;
3179 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3180 $queued{$self->{formname}}, $self->{formname});
3186 $main::lxdebug->leave_sub();
3190 $main::lxdebug->enter_sub();
3192 my ($self, $dbh) = @_;
3194 my ($query, $printed, $emailed);
3196 my $formnames = $self->{printed};
3197 my $emailforms = $self->{emailed};
3199 $query = qq|DELETE FROM status
3200 WHERE (formname = ?) AND (trans_id = ?)|;
3201 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3203 # this only applies to the forms
3204 # checks and receipts are posted when printed or queued
3206 if ($self->{queued}) {
3207 my %queued = split / /, $self->{queued};
3209 foreach my $formname (keys %queued) {
3210 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3211 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3213 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3214 VALUES (?, ?, ?, ?, ?)|;
3215 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3217 $formnames =~ s/\Q$self->{formname}\E//;
3218 $emailforms =~ s/\Q$self->{formname}\E//;
3223 # save printed, emailed info
3224 $formnames =~ s/^ +//g;
3225 $emailforms =~ s/^ +//g;
3228 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3229 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3231 foreach my $formname (keys %status) {
3232 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3233 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3235 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3236 VALUES (?, ?, ?, ?)|;
3237 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3240 $main::lxdebug->leave_sub();
3244 # $main::locale->text('SAVED')
3245 # $main::locale->text('DELETED')
3246 # $main::locale->text('ADDED')
3247 # $main::locale->text('PAYMENT POSTED')
3248 # $main::locale->text('POSTED')
3249 # $main::locale->text('POSTED AS NEW')
3250 # $main::locale->text('ELSE')
3251 # $main::locale->text('SAVED FOR DUNNING')
3252 # $main::locale->text('DUNNING STARTED')
3253 # $main::locale->text('PRINTED')
3254 # $main::locale->text('MAILED')
3255 # $main::locale->text('SCREENED')
3256 # $main::locale->text('CANCELED')
3257 # $main::locale->text('invoice')
3258 # $main::locale->text('proforma')
3259 # $main::locale->text('sales_order')
3260 # $main::locale->text('pick_list')
3261 # $main::locale->text('purchase_order')
3262 # $main::locale->text('bin_list')
3263 # $main::locale->text('sales_quotation')
3264 # $main::locale->text('request_quotation')
3267 $main::lxdebug->enter_sub();
3270 my $dbh = shift || $self->get_standard_dbh;
3272 if(!exists $self->{employee_id}) {
3273 &get_employee($self, $dbh);
3277 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3278 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3279 my @values = (conv_i($self->{id}), $self->{login},
3280 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3281 do_query($self, $dbh, $query, @values);
3285 $main::lxdebug->leave_sub();
3289 $main::lxdebug->enter_sub();
3291 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3292 my ($orderBy, $desc) = split(/\-\-/, $order);
3293 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3296 if ($trans_id ne "") {
3298 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 | .
3299 qq|FROM history_erp h | .
3300 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3301 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3304 my $sth = $dbh->prepare($query) || $self->dberror($query);
3306 $sth->execute() || $self->dberror("$query");
3308 while(my $hash_ref = $sth->fetchrow_hashref()) {
3309 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3310 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3311 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3312 $tempArray[$i++] = $hash_ref;
3314 $main::lxdebug->leave_sub() and return \@tempArray
3315 if ($i > 0 && $tempArray[0] ne "");
3317 $main::lxdebug->leave_sub();
3321 sub update_defaults {
3322 $main::lxdebug->enter_sub();
3324 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3327 if ($provided_dbh) {
3328 $dbh = $provided_dbh;
3330 $dbh = $self->dbconnect_noauto($myconfig);
3332 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3333 my $sth = $dbh->prepare($query);
3335 $sth->execute || $self->dberror($query);
3336 my ($var) = $sth->fetchrow_array;
3339 if ($var =~ m/\d+$/) {
3340 my $new_var = (substr $var, $-[0]) * 1 + 1;
3341 my $len_diff = length($var) - $-[0] - length($new_var);
3342 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3348 $query = qq|UPDATE defaults SET $fld = ?|;
3349 do_query($self, $dbh, $query, $var);
3351 if (!$provided_dbh) {
3356 $main::lxdebug->leave_sub();
3361 sub update_business {
3362 $main::lxdebug->enter_sub();
3364 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3367 if ($provided_dbh) {
3368 $dbh = $provided_dbh;
3370 $dbh = $self->dbconnect_noauto($myconfig);
3373 qq|SELECT customernumberinit FROM business
3374 WHERE id = ? FOR UPDATE|;
3375 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3377 return undef unless $var;
3379 if ($var =~ m/\d+$/) {
3380 my $new_var = (substr $var, $-[0]) * 1 + 1;
3381 my $len_diff = length($var) - $-[0] - length($new_var);
3382 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3388 $query = qq|UPDATE business
3389 SET customernumberinit = ?
3391 do_query($self, $dbh, $query, $var, $business_id);
3393 if (!$provided_dbh) {
3398 $main::lxdebug->leave_sub();
3403 sub get_partsgroup {
3404 $main::lxdebug->enter_sub();
3406 my ($self, $myconfig, $p) = @_;
3407 my $target = $p->{target} || 'all_partsgroup';
3409 my $dbh = $self->get_standard_dbh($myconfig);
3411 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3413 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3416 if ($p->{searchitems} eq 'part') {
3417 $query .= qq|WHERE p.inventory_accno_id > 0|;
3419 if ($p->{searchitems} eq 'service') {
3420 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3422 if ($p->{searchitems} eq 'assembly') {
3423 $query .= qq|WHERE p.assembly = '1'|;
3425 if ($p->{searchitems} eq 'labor') {
3426 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3429 $query .= qq|ORDER BY partsgroup|;
3432 $query = qq|SELECT id, partsgroup FROM partsgroup
3433 ORDER BY partsgroup|;
3436 if ($p->{language_code}) {
3437 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3438 t.description AS translation
3440 JOIN parts p ON (p.partsgroup_id = pg.id)
3441 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3442 ORDER BY translation|;
3443 @values = ($p->{language_code});
3446 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3448 $main::lxdebug->leave_sub();
3451 sub get_pricegroup {
3452 $main::lxdebug->enter_sub();
3454 my ($self, $myconfig, $p) = @_;
3456 my $dbh = $self->get_standard_dbh($myconfig);
3458 my $query = qq|SELECT p.id, p.pricegroup
3461 $query .= qq| ORDER BY pricegroup|;
3464 $query = qq|SELECT id, pricegroup FROM pricegroup
3465 ORDER BY pricegroup|;
3468 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3470 $main::lxdebug->leave_sub();
3474 # usage $form->all_years($myconfig, [$dbh])
3475 # return list of all years where bookings found
3478 $main::lxdebug->enter_sub();
3480 my ($self, $myconfig, $dbh) = @_;
3482 $dbh ||= $self->get_standard_dbh($myconfig);
3485 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3486 (SELECT MAX(transdate) FROM acc_trans)|;
3487 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3489 if ($myconfig->{dateformat} =~ /^yy/) {
3490 ($startdate) = split /\W/, $startdate;
3491 ($enddate) = split /\W/, $enddate;
3493 (@_) = split /\W/, $startdate;
3495 (@_) = split /\W/, $enddate;
3500 $startdate = substr($startdate,0,4);
3501 $enddate = substr($enddate,0,4);
3503 while ($enddate >= $startdate) {
3504 push @all_years, $enddate--;
3509 $main::lxdebug->leave_sub();
3513 $main::lxdebug->enter_sub();
3517 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3519 $main::lxdebug->leave_sub();
3523 $main::lxdebug->enter_sub();
3528 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3530 $main::lxdebug->leave_sub();
3533 sub prepare_for_printing {
3536 $self->{templates} ||= $::myconfig{templates};
3537 $self->{formname} ||= $self->{type};
3538 $self->{media} ||= 'email';
3540 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3542 # set shipto from billto unless set
3543 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3544 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3545 $self->{shiptoname} = $::myconfig{company};
3546 $self->{shiptostreet} = $::myconfig{address};
3549 my $language = $self->{language} ? '_' . $self->{language} : '';
3551 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3552 if ($self->{language_id}) {
3553 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3555 $output_dateformat = $::myconfig{dateformat};
3556 $output_numberformat = $::myconfig{numberformat};
3557 $output_longdates = 1;
3560 # Retrieve accounts for tax calculation.
3561 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3563 if ($self->{type} =~ /_delivery_order$/) {
3564 DO->order_details();
3565 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3566 OE->order_details(\%::myconfig, $self);
3568 IS->invoice_details(\%::myconfig, $self, $::locale);
3571 # Chose extension & set source file name
3572 my $extension = 'html';
3573 if ($self->{format} eq 'postscript') {
3574 $self->{postscript} = 1;
3576 } elsif ($self->{"format"} =~ /pdf/) {
3578 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3579 } elsif ($self->{"format"} =~ /opendocument/) {
3580 $self->{opendocument} = 1;
3582 } elsif ($self->{"format"} =~ /excel/) {
3587 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3588 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3589 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3592 $self->format_dates($output_dateformat, $output_longdates,
3593 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3594 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3595 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3597 $self->reformat_numbers($output_numberformat, 2,
3598 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3599 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3601 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3603 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3605 if (scalar @{ $cvar_date_fields }) {
3606 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3609 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3610 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3617 my ($self, $dateformat, $longformat, @indices) = @_;
3619 $dateformat ||= $::myconfig{dateformat};
3621 foreach my $idx (@indices) {
3622 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3623 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3624 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3628 next unless defined $self->{$idx};
3630 if (!ref($self->{$idx})) {
3631 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3633 } elsif (ref($self->{$idx}) eq "ARRAY") {
3634 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3635 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3641 sub reformat_numbers {
3642 my ($self, $numberformat, $places, @indices) = @_;
3644 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3646 foreach my $idx (@indices) {
3647 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3648 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3649 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3653 next unless defined $self->{$idx};
3655 if (!ref($self->{$idx})) {
3656 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3658 } elsif (ref($self->{$idx}) eq "ARRAY") {
3659 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3660 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3665 my $saved_numberformat = $::myconfig{numberformat};
3666 $::myconfig{numberformat} = $numberformat;
3668 foreach my $idx (@indices) {
3669 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3670 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3671 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3675 next unless defined $self->{$idx};
3677 if (!ref($self->{$idx})) {
3678 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3680 } elsif (ref($self->{$idx}) eq "ARRAY") {
3681 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3682 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3687 $::myconfig{numberformat} = $saved_numberformat;
3696 SL::Form.pm - main data object.
3700 This is the main data object of Lx-Office.
3701 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3702 Points of interest for a beginner are:
3704 - $form->error - renders a generic error in html. accepts an error message
3705 - $form->get_standard_dbh - returns a database connection for the
3707 =head1 SPECIAL FUNCTIONS
3709 =head2 C<_store_value()>
3711 parses a complex var name, and stores it in the form.
3714 $form->_store_value($key, $value);
3716 keys must start with a string, and can contain various tokens.
3717 supported key structures are:
3720 simple key strings work as expected
3725 separating two keys by a dot (.) will result in a hash lookup for the inner value
3726 this is similar to the behaviour of java and templating mechanisms.
3728 filter.description => $form->{filter}->{description}
3730 3. array+hashref access
3732 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3733 using [+] instead of [] will force a new array index. this is useful for recurring
3734 data structures like part lists. put a [+] into the first varname, and use [] on the
3737 repeating these names in your template:
3740 invoice.items[].parts_id
3744 $form->{invoice}->{items}->[
3758 using brackets at the end of a name will result in a pure array to be created.
3759 note that you mustn't use [+], which is reserved for array+hash access and will
3760 result in undefined behaviour in array context.
3762 filter.status[] => $form->{status}->[ val1, val2, ... ]
3764 =head2 C<update_business> PARAMS
3767 \%config, - config hashref
3768 $business_id, - business id
3769 $dbh - optional database handle
3771 handles business (thats customer/vendor types) sequences.
3773 special behaviour for empty strings in customerinitnumber field:
3774 will in this case not increase the value, and return undef.
3776 =head2 C<redirect_header> $url
3778 Generates a HTTP redirection header for the new C<$url>. Constructs an
3779 absolute URL including scheme, host name and port. If C<$url> is a
3780 relative URL then it is considered relative to Lx-Office base URL.
3782 This function C<die>s if headers have already been created with
3783 C<$::form-E<gt>header>.
3787 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3788 print $::form->redirect_header('http://www.lx-office.org/');
3792 Generates a general purpose http/html header and includes most of the scripts
3793 ans stylesheets needed.
3795 Only one header will be generated. If the method was already called in this
3796 request it will not output anything and return undef. Also if no
3797 HTTP_USER_AGENT is found, no header is generated.
3799 Although header does not accept parameters itself, it will honor special
3800 hashkeys of its Form instance:
3808 If one of these is set, a http-equiv refresh is generated. Missing parameters
3809 default to 3 seconds and the refering url.
3815 If these are arrayrefs the contents will be inlined into the header.
3819 If true, a css snippet will be generated that sets the page in landscape mode.
3823 Used to override the default favicon.
3827 A html page title will be generated from this