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);
1255 map { $self->{"myconfig_${_}"} = $myconfig->{$_} } grep { $_ ne 'dbpasswd' } keys %{ $myconfig };
1257 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1259 # OUT is used for the media, screen, printer, email
1260 # for postscript we store a copy in a temporary file
1262 my $prepend_userspath;
1264 if (!$self->{tmpfile}) {
1265 $self->{tmpfile} = "${fileid}.$self->{IN}";
1266 $prepend_userspath = 1;
1269 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1271 $self->{tmpfile} =~ s|.*/||;
1272 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1273 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1275 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1276 $out = $self->{OUT};
1277 $self->{OUT} = ">$self->{tmpfile}";
1283 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1284 $result = $template->parse(*OUT);
1289 $result = $template->parse(*STDOUT);
1294 $self->error("$self->{IN} : " . $template->get_error());
1297 if ($self->{media} eq 'file') {
1298 copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1300 chdir("$self->{cwd}");
1302 $::lxdebug->leave_sub();
1307 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1309 if ($self->{media} eq 'email') {
1311 my $mail = new Mailer;
1313 map { $mail->{$_} = $self->{$_} }
1314 qw(cc bcc subject message version format);
1315 $mail->{charset} = $::lx_office_conf{system}->{dbcharset} || Common::DEFAULT_CHARSET;
1316 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1317 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1318 $mail->{fileid} = "$fileid.";
1319 $myconfig->{signature} =~ s/\r//g;
1321 # if we send html or plain text inline
1322 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1323 $mail->{contenttype} = "text/html";
1325 $mail->{message} =~ s/\r//g;
1326 $mail->{message} =~ s/\n/<br>\n/g;
1327 $myconfig->{signature} =~ s/\n/<br>\n/g;
1328 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1330 open(IN, $self->{tmpfile})
1331 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1333 $mail->{message} .= $_;
1340 if (!$self->{"do_not_attach"}) {
1341 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1342 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1343 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1344 "name" => $attachment_name }];
1347 $mail->{message} =~ s/\r//g;
1348 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1352 my $err = $mail->send();
1353 $self->error($self->cleanup . "$err") if ($err);
1357 $self->{OUT} = $out;
1359 my $numbytes = (-s $self->{tmpfile});
1360 open(IN, $self->{tmpfile})
1361 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1363 $self->{copies} = 1 unless $self->{media} eq 'printer';
1365 chdir("$self->{cwd}");
1366 #print(STDERR "Kopien $self->{copies}\n");
1367 #print(STDERR "OUT $self->{OUT}\n");
1368 for my $i (1 .. $self->{copies}) {
1370 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1371 print OUT while <IN>;
1376 $self->{attachment_filename} = ($self->{attachment_filename})
1377 ? $self->{attachment_filename}
1378 : $self->generate_attachment_filename();
1380 # launch application
1381 print qq|Content-Type: | . $template->get_mime_type() . qq|
1382 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1383 Content-Length: $numbytes
1387 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1398 chdir("$self->{cwd}");
1399 $main::lxdebug->leave_sub();
1402 sub get_formname_translation {
1403 $main::lxdebug->enter_sub();
1404 my ($self, $formname) = @_;
1406 $formname ||= $self->{formname};
1408 my %formname_translations = (
1409 bin_list => $main::locale->text('Bin List'),
1410 credit_note => $main::locale->text('Credit Note'),
1411 invoice => $main::locale->text('Invoice'),
1412 pick_list => $main::locale->text('Pick List'),
1413 proforma => $main::locale->text('Proforma Invoice'),
1414 purchase_order => $main::locale->text('Purchase Order'),
1415 request_quotation => $main::locale->text('RFQ'),
1416 sales_order => $main::locale->text('Confirmation'),
1417 sales_quotation => $main::locale->text('Quotation'),
1418 storno_invoice => $main::locale->text('Storno Invoice'),
1419 sales_delivery_order => $main::locale->text('Delivery Order'),
1420 purchase_delivery_order => $main::locale->text('Delivery Order'),
1421 dunning => $main::locale->text('Dunning'),
1424 $main::lxdebug->leave_sub();
1425 return $formname_translations{$formname}
1428 sub get_number_prefix_for_type {
1429 $main::lxdebug->enter_sub();
1433 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1434 : ($self->{type} =~ /_quotation$/) ? 'quo'
1435 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1438 $main::lxdebug->leave_sub();
1442 sub get_extension_for_format {
1443 $main::lxdebug->enter_sub();
1446 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1447 : $self->{format} =~ /postscript/i ? ".ps"
1448 : $self->{format} =~ /opendocument/i ? ".odt"
1449 : $self->{format} =~ /excel/i ? ".xls"
1450 : $self->{format} =~ /html/i ? ".html"
1453 $main::lxdebug->leave_sub();
1457 sub generate_attachment_filename {
1458 $main::lxdebug->enter_sub();
1461 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1462 my $prefix = $self->get_number_prefix_for_type();
1464 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1465 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1467 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1468 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1471 $attachment_filename = "";
1474 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1475 $attachment_filename =~ s|[\s/\\]+|_|g;
1477 $main::lxdebug->leave_sub();
1478 return $attachment_filename;
1481 sub generate_email_subject {
1482 $main::lxdebug->enter_sub();
1485 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1486 my $prefix = $self->get_number_prefix_for_type();
1488 if ($subject && $self->{"${prefix}number"}) {
1489 $subject .= " " . $self->{"${prefix}number"}
1492 $main::lxdebug->leave_sub();
1497 $main::lxdebug->enter_sub();
1501 chdir("$self->{tmpdir}");
1504 if (-f "$self->{tmpfile}.err") {
1505 open(FH, "$self->{tmpfile}.err");
1510 if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1511 $self->{tmpfile} =~ s|.*/||g;
1513 $self->{tmpfile} =~ s/\.\w+$//g;
1514 my $tmpfile = $self->{tmpfile};
1515 unlink(<$tmpfile.*>);
1518 chdir("$self->{cwd}");
1520 $main::lxdebug->leave_sub();
1526 $main::lxdebug->enter_sub();
1528 my ($self, $date, $myconfig) = @_;
1531 if ($date && $date =~ /\D/) {
1533 if ($myconfig->{dateformat} =~ /^yy/) {
1534 ($yy, $mm, $dd) = split /\D/, $date;
1536 if ($myconfig->{dateformat} =~ /^mm/) {
1537 ($mm, $dd, $yy) = split /\D/, $date;
1539 if ($myconfig->{dateformat} =~ /^dd/) {
1540 ($dd, $mm, $yy) = split /\D/, $date;
1545 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1546 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1548 $dd = "0$dd" if ($dd < 10);
1549 $mm = "0$mm" if ($mm < 10);
1551 $date = "$yy$mm$dd";
1554 $main::lxdebug->leave_sub();
1559 # Database routines used throughout
1561 sub _dbconnect_options {
1563 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1570 $main::lxdebug->enter_sub(2);
1572 my ($self, $myconfig) = @_;
1574 # connect to database
1575 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1579 if ($myconfig->{dboptions}) {
1580 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1583 $main::lxdebug->leave_sub(2);
1588 sub dbconnect_noauto {
1589 $main::lxdebug->enter_sub();
1591 my ($self, $myconfig) = @_;
1593 # connect to database
1594 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1598 if ($myconfig->{dboptions}) {
1599 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1602 $main::lxdebug->leave_sub();
1607 sub get_standard_dbh {
1608 $main::lxdebug->enter_sub(2);
1611 my $myconfig = shift || \%::myconfig;
1613 if ($standard_dbh && !$standard_dbh->{Active}) {
1614 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1615 undef $standard_dbh;
1618 $standard_dbh ||= SL::DB::create->dbh;
1620 $main::lxdebug->leave_sub(2);
1622 return $standard_dbh;
1626 $main::lxdebug->enter_sub();
1628 my ($self, $date, $myconfig) = @_;
1629 my $dbh = $self->dbconnect($myconfig);
1631 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1632 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1633 my ($closed) = $sth->fetchrow_array;
1635 $main::lxdebug->leave_sub();
1640 sub update_balance {
1641 $main::lxdebug->enter_sub();
1643 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1645 # if we have a value, go do it
1648 # retrieve balance from table
1649 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1650 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1651 my ($balance) = $sth->fetchrow_array;
1657 $query = "UPDATE $table SET $field = $balance WHERE $where";
1658 do_query($self, $dbh, $query, @values);
1660 $main::lxdebug->leave_sub();
1663 sub update_exchangerate {
1664 $main::lxdebug->enter_sub();
1666 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1668 # some sanity check for currency
1670 $main::lxdebug->leave_sub();
1673 $query = qq|SELECT curr FROM defaults|;
1675 my ($currency) = selectrow_query($self, $dbh, $query);
1676 my ($defaultcurrency) = split m/:/, $currency;
1679 if ($curr eq $defaultcurrency) {
1680 $main::lxdebug->leave_sub();
1684 $query = qq|SELECT e.curr FROM exchangerate e
1685 WHERE e.curr = ? AND e.transdate = ?
1687 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1696 $buy = conv_i($buy, "NULL");
1697 $sell = conv_i($sell, "NULL");
1700 if ($buy != 0 && $sell != 0) {
1701 $set = "buy = $buy, sell = $sell";
1702 } elsif ($buy != 0) {
1703 $set = "buy = $buy";
1704 } elsif ($sell != 0) {
1705 $set = "sell = $sell";
1708 if ($sth->fetchrow_array) {
1709 $query = qq|UPDATE exchangerate
1715 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1716 VALUES (?, $buy, $sell, ?)|;
1719 do_query($self, $dbh, $query, $curr, $transdate);
1721 $main::lxdebug->leave_sub();
1724 sub save_exchangerate {
1725 $main::lxdebug->enter_sub();
1727 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1729 my $dbh = $self->dbconnect($myconfig);
1733 $buy = $rate if $fld eq 'buy';
1734 $sell = $rate if $fld eq 'sell';
1737 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1742 $main::lxdebug->leave_sub();
1745 sub get_exchangerate {
1746 $main::lxdebug->enter_sub();
1748 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1751 unless ($transdate) {
1752 $main::lxdebug->leave_sub();
1756 $query = qq|SELECT curr FROM defaults|;
1758 my ($currency) = selectrow_query($self, $dbh, $query);
1759 my ($defaultcurrency) = split m/:/, $currency;
1761 if ($currency eq $defaultcurrency) {
1762 $main::lxdebug->leave_sub();
1766 $query = qq|SELECT e.$fld FROM exchangerate e
1767 WHERE e.curr = ? AND e.transdate = ?|;
1768 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1772 $main::lxdebug->leave_sub();
1774 return $exchangerate;
1777 sub check_exchangerate {
1778 $main::lxdebug->enter_sub();
1780 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1782 if ($fld !~/^buy|sell$/) {
1783 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1786 unless ($transdate) {
1787 $main::lxdebug->leave_sub();
1791 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1793 if ($currency eq $defaultcurrency) {
1794 $main::lxdebug->leave_sub();
1798 my $dbh = $self->get_standard_dbh($myconfig);
1799 my $query = qq|SELECT e.$fld FROM exchangerate e
1800 WHERE e.curr = ? AND e.transdate = ?|;
1802 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1804 $main::lxdebug->leave_sub();
1806 return $exchangerate;
1809 sub get_all_currencies {
1810 $main::lxdebug->enter_sub();
1813 my $myconfig = shift || \%::myconfig;
1814 my $dbh = $self->get_standard_dbh($myconfig);
1816 my $query = qq|SELECT curr FROM defaults|;
1818 my ($curr) = selectrow_query($self, $dbh, $query);
1819 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1821 $main::lxdebug->leave_sub();
1826 sub get_default_currency {
1827 $main::lxdebug->enter_sub();
1829 my ($self, $myconfig) = @_;
1830 my @currencies = $self->get_all_currencies($myconfig);
1832 $main::lxdebug->leave_sub();
1834 return $currencies[0];
1837 sub set_payment_options {
1838 $main::lxdebug->enter_sub();
1840 my ($self, $myconfig, $transdate) = @_;
1842 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1844 my $dbh = $self->get_standard_dbh($myconfig);
1847 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1848 qq|FROM payment_terms p | .
1851 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1852 $self->{payment_terms}) =
1853 selectrow_query($self, $dbh, $query, $self->{payment_id});
1855 if ($transdate eq "") {
1856 if ($self->{invdate}) {
1857 $transdate = $self->{invdate};
1859 $transdate = $self->{transdate};
1864 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1865 qq|FROM payment_terms|;
1866 ($self->{netto_date}, $self->{skonto_date}) =
1867 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1869 my ($invtotal, $total);
1870 my (%amounts, %formatted_amounts);
1872 if ($self->{type} =~ /_order$/) {
1873 $amounts{invtotal} = $self->{ordtotal};
1874 $amounts{total} = $self->{ordtotal};
1876 } elsif ($self->{type} =~ /_quotation$/) {
1877 $amounts{invtotal} = $self->{quototal};
1878 $amounts{total} = $self->{quototal};
1881 $amounts{invtotal} = $self->{invtotal};
1882 $amounts{total} = $self->{total};
1884 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1886 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1888 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1889 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1890 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1892 foreach (keys %amounts) {
1893 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1894 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1897 if ($self->{"language_id"}) {
1899 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1900 qq|FROM translation_payment_terms t | .
1901 qq|LEFT JOIN language l ON t.language_id = l.id | .
1902 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1903 my ($description_long, $output_numberformat, $output_dateformat,
1904 $output_longdates) =
1905 selectrow_query($self, $dbh, $query,
1906 $self->{"language_id"}, $self->{"payment_id"});
1908 $self->{payment_terms} = $description_long if ($description_long);
1910 if ($output_dateformat) {
1911 foreach my $key (qw(netto_date skonto_date)) {
1913 $main::locale->reformat_date($myconfig, $self->{$key},
1919 if ($output_numberformat &&
1920 ($output_numberformat ne $myconfig->{"numberformat"})) {
1921 my $saved_numberformat = $myconfig->{"numberformat"};
1922 $myconfig->{"numberformat"} = $output_numberformat;
1923 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1924 $myconfig->{"numberformat"} = $saved_numberformat;
1928 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1929 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1930 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1931 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1932 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1933 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1934 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1936 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1938 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1940 $main::lxdebug->leave_sub();
1944 sub get_template_language {
1945 $main::lxdebug->enter_sub();
1947 my ($self, $myconfig) = @_;
1949 my $template_code = "";
1951 if ($self->{language_id}) {
1952 my $dbh = $self->get_standard_dbh($myconfig);
1953 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1954 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1957 $main::lxdebug->leave_sub();
1959 return $template_code;
1962 sub get_printer_code {
1963 $main::lxdebug->enter_sub();
1965 my ($self, $myconfig) = @_;
1967 my $template_code = "";
1969 if ($self->{printer_id}) {
1970 my $dbh = $self->get_standard_dbh($myconfig);
1971 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1972 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1975 $main::lxdebug->leave_sub();
1977 return $template_code;
1981 $main::lxdebug->enter_sub();
1983 my ($self, $myconfig) = @_;
1985 my $template_code = "";
1987 if ($self->{shipto_id}) {
1988 my $dbh = $self->get_standard_dbh($myconfig);
1989 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1990 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1991 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1994 $main::lxdebug->leave_sub();
1998 $main::lxdebug->enter_sub();
2000 my ($self, $dbh, $id, $module) = @_;
2005 foreach my $item (qw(name department_1 department_2 street zipcode city country
2006 contact cp_gender phone fax email)) {
2007 if ($self->{"shipto$item"}) {
2008 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2010 push(@values, $self->{"shipto${item}"});
2014 if ($self->{shipto_id}) {
2015 my $query = qq|UPDATE shipto set
2017 shiptodepartment_1 = ?,
2018 shiptodepartment_2 = ?,
2024 shiptocp_gender = ?,
2028 WHERE shipto_id = ?|;
2029 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2031 my $query = qq|SELECT * FROM shipto
2032 WHERE shiptoname = ? AND
2033 shiptodepartment_1 = ? AND
2034 shiptodepartment_2 = ? AND
2035 shiptostreet = ? AND
2036 shiptozipcode = ? AND
2038 shiptocountry = ? AND
2039 shiptocontact = ? AND
2040 shiptocp_gender = ? AND
2046 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2049 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2050 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2051 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2052 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2053 do_query($self, $dbh, $query, $id, @values, $module);
2058 $main::lxdebug->leave_sub();
2062 $main::lxdebug->enter_sub();
2064 my ($self, $dbh) = @_;
2066 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2068 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2069 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2070 $self->{"employee_id"} *= 1;
2072 $main::lxdebug->leave_sub();
2075 sub get_employee_data {
2076 $main::lxdebug->enter_sub();
2081 Common::check_params(\%params, qw(prefix));
2082 Common::check_params_x(\%params, qw(id));
2085 $main::lxdebug->leave_sub();
2089 my $myconfig = \%main::myconfig;
2090 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2092 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2095 my $user = User->new($login);
2096 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2098 $self->{$params{prefix} . '_login'} = $login;
2099 $self->{$params{prefix} . '_name'} ||= $login;
2102 $main::lxdebug->leave_sub();
2106 $main::lxdebug->enter_sub();
2108 my ($self, $myconfig, $reference_date) = @_;
2110 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2112 my $dbh = $self->get_standard_dbh($myconfig);
2113 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2114 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2116 $main::lxdebug->leave_sub();
2122 $main::lxdebug->enter_sub();
2124 my ($self, $dbh, $id, $key) = @_;
2126 $key = "all_contacts" unless ($key);
2130 $main::lxdebug->leave_sub();
2135 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2136 qq|FROM contacts | .
2137 qq|WHERE cp_cv_id = ? | .
2138 qq|ORDER BY lower(cp_name)|;
2140 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2142 $main::lxdebug->leave_sub();
2146 $main::lxdebug->enter_sub();
2148 my ($self, $dbh, $key) = @_;
2150 my ($all, $old_id, $where, @values);
2152 if (ref($key) eq "HASH") {
2155 $key = "ALL_PROJECTS";
2157 foreach my $p (keys(%{$params})) {
2159 $all = $params->{$p};
2160 } elsif ($p eq "old_id") {
2161 $old_id = $params->{$p};
2162 } elsif ($p eq "key") {
2163 $key = $params->{$p};
2169 $where = "WHERE active ";
2171 if (ref($old_id) eq "ARRAY") {
2172 my @ids = grep({ $_ } @{$old_id});
2174 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2175 push(@values, @ids);
2178 $where .= " OR (id = ?) ";
2179 push(@values, $old_id);
2185 qq|SELECT id, projectnumber, description, active | .
2188 qq|ORDER BY lower(projectnumber)|;
2190 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2192 $main::lxdebug->leave_sub();
2196 $main::lxdebug->enter_sub();
2198 my ($self, $dbh, $vc_id, $key) = @_;
2200 $key = "all_shipto" unless ($key);
2203 # get shipping addresses
2204 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2206 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2212 $main::lxdebug->leave_sub();
2216 $main::lxdebug->enter_sub();
2218 my ($self, $dbh, $key) = @_;
2220 $key = "all_printers" unless ($key);
2222 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2224 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2226 $main::lxdebug->leave_sub();
2230 $main::lxdebug->enter_sub();
2232 my ($self, $dbh, $params) = @_;
2235 $key = $params->{key};
2236 $key = "all_charts" unless ($key);
2238 my $transdate = quote_db_date($params->{transdate});
2241 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2243 qq|LEFT JOIN taxkeys tk ON | .
2244 qq|(tk.id = (SELECT id FROM taxkeys | .
2245 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2246 qq| ORDER BY startdate DESC LIMIT 1)) | .
2247 qq|ORDER BY c.accno|;
2249 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2251 $main::lxdebug->leave_sub();
2254 sub _get_taxcharts {
2255 $main::lxdebug->enter_sub();
2257 my ($self, $dbh, $params) = @_;
2259 my $key = "all_taxcharts";
2262 if (ref $params eq 'HASH') {
2263 $key = $params->{key} if ($params->{key});
2264 if ($params->{module} eq 'AR') {
2265 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2267 } elsif ($params->{module} eq 'AP') {
2268 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2275 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2277 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2279 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2281 $main::lxdebug->leave_sub();
2285 $main::lxdebug->enter_sub();
2287 my ($self, $dbh, $key) = @_;
2289 $key = "all_taxzones" unless ($key);
2291 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2293 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2295 $main::lxdebug->leave_sub();
2298 sub _get_employees {
2299 $main::lxdebug->enter_sub();
2301 my ($self, $dbh, $default_key, $key) = @_;
2303 $key = $default_key unless ($key);
2304 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2306 $main::lxdebug->leave_sub();
2309 sub _get_business_types {
2310 $main::lxdebug->enter_sub();
2312 my ($self, $dbh, $key) = @_;
2314 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2315 $options->{key} ||= "all_business_types";
2318 if (exists $options->{salesman}) {
2319 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2322 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2324 $main::lxdebug->leave_sub();
2327 sub _get_languages {
2328 $main::lxdebug->enter_sub();
2330 my ($self, $dbh, $key) = @_;
2332 $key = "all_languages" unless ($key);
2334 my $query = qq|SELECT * FROM language ORDER BY id|;
2336 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2338 $main::lxdebug->leave_sub();
2341 sub _get_dunning_configs {
2342 $main::lxdebug->enter_sub();
2344 my ($self, $dbh, $key) = @_;
2346 $key = "all_dunning_configs" unless ($key);
2348 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2350 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2352 $main::lxdebug->leave_sub();
2355 sub _get_currencies {
2356 $main::lxdebug->enter_sub();
2358 my ($self, $dbh, $key) = @_;
2360 $key = "all_currencies" unless ($key);
2362 my $query = qq|SELECT curr AS currency FROM defaults|;
2364 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2366 $main::lxdebug->leave_sub();
2370 $main::lxdebug->enter_sub();
2372 my ($self, $dbh, $key) = @_;
2374 $key = "all_payments" unless ($key);
2376 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2378 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2380 $main::lxdebug->leave_sub();
2383 sub _get_customers {
2384 $main::lxdebug->enter_sub();
2386 my ($self, $dbh, $key) = @_;
2388 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2389 $options->{key} ||= "all_customers";
2390 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2393 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2394 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2395 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2397 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2398 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2400 $main::lxdebug->leave_sub();
2404 $main::lxdebug->enter_sub();
2406 my ($self, $dbh, $key) = @_;
2408 $key = "all_vendors" unless ($key);
2410 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2412 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2414 $main::lxdebug->leave_sub();
2417 sub _get_departments {
2418 $main::lxdebug->enter_sub();
2420 my ($self, $dbh, $key) = @_;
2422 $key = "all_departments" unless ($key);
2424 my $query = qq|SELECT * FROM department ORDER BY description|;
2426 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2428 $main::lxdebug->leave_sub();
2431 sub _get_warehouses {
2432 $main::lxdebug->enter_sub();
2434 my ($self, $dbh, $param) = @_;
2436 my ($key, $bins_key);
2438 if ('' eq ref $param) {
2442 $key = $param->{key};
2443 $bins_key = $param->{bins};
2446 my $query = qq|SELECT w.* FROM warehouse w
2447 WHERE (NOT w.invalid) AND
2448 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2449 ORDER BY w.sortkey|;
2451 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2454 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2455 my $sth = prepare_query($self, $dbh, $query);
2457 foreach my $warehouse (@{ $self->{$key} }) {
2458 do_statement($self, $sth, $query, $warehouse->{id});
2459 $warehouse->{$bins_key} = [];
2461 while (my $ref = $sth->fetchrow_hashref()) {
2462 push @{ $warehouse->{$bins_key} }, $ref;
2468 $main::lxdebug->leave_sub();
2472 $main::lxdebug->enter_sub();
2474 my ($self, $dbh, $table, $key, $sortkey) = @_;
2476 my $query = qq|SELECT * FROM $table|;
2477 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2479 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2481 $main::lxdebug->leave_sub();
2485 # $main::lxdebug->enter_sub();
2487 # my ($self, $dbh, $key) = @_;
2489 # $key ||= "all_groups";
2491 # my $groups = $main::auth->read_groups();
2493 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2495 # $main::lxdebug->leave_sub();
2499 $main::lxdebug->enter_sub();
2504 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2505 my ($sth, $query, $ref);
2507 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2508 my $vc_id = $self->{"${vc}_id"};
2510 if ($params{"contacts"}) {
2511 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2514 if ($params{"shipto"}) {
2515 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2518 if ($params{"projects"} || $params{"all_projects"}) {
2519 $self->_get_projects($dbh, $params{"all_projects"} ?
2520 $params{"all_projects"} : $params{"projects"},
2521 $params{"all_projects"} ? 1 : 0);
2524 if ($params{"printers"}) {
2525 $self->_get_printers($dbh, $params{"printers"});
2528 if ($params{"languages"}) {
2529 $self->_get_languages($dbh, $params{"languages"});
2532 if ($params{"charts"}) {
2533 $self->_get_charts($dbh, $params{"charts"});
2536 if ($params{"taxcharts"}) {
2537 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2540 if ($params{"taxzones"}) {
2541 $self->_get_taxzones($dbh, $params{"taxzones"});
2544 if ($params{"employees"}) {
2545 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2548 if ($params{"salesmen"}) {
2549 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2552 if ($params{"business_types"}) {
2553 $self->_get_business_types($dbh, $params{"business_types"});
2556 if ($params{"dunning_configs"}) {
2557 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2560 if($params{"currencies"}) {
2561 $self->_get_currencies($dbh, $params{"currencies"});
2564 if($params{"customers"}) {
2565 $self->_get_customers($dbh, $params{"customers"});
2568 if($params{"vendors"}) {
2569 if (ref $params{"vendors"} eq 'HASH') {
2570 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2572 $self->_get_vendors($dbh, $params{"vendors"});
2576 if($params{"payments"}) {
2577 $self->_get_payments($dbh, $params{"payments"});
2580 if($params{"departments"}) {
2581 $self->_get_departments($dbh, $params{"departments"});
2584 if ($params{price_factors}) {
2585 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2588 if ($params{warehouses}) {
2589 $self->_get_warehouses($dbh, $params{warehouses});
2592 # if ($params{groups}) {
2593 # $self->_get_groups($dbh, $params{groups});
2596 if ($params{partsgroup}) {
2597 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2600 $main::lxdebug->leave_sub();
2603 # this sub gets the id and name from $table
2605 $main::lxdebug->enter_sub();
2607 my ($self, $myconfig, $table) = @_;
2609 # connect to database
2610 my $dbh = $self->get_standard_dbh($myconfig);
2612 $table = $table eq "customer" ? "customer" : "vendor";
2613 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2615 my ($query, @values);
2617 if (!$self->{openinvoices}) {
2619 if ($self->{customernumber} ne "") {
2620 $where = qq|(vc.customernumber ILIKE ?)|;
2621 push(@values, '%' . $self->{customernumber} . '%');
2623 $where = qq|(vc.name ILIKE ?)|;
2624 push(@values, '%' . $self->{$table} . '%');
2628 qq~SELECT vc.id, vc.name,
2629 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2631 WHERE $where AND (NOT vc.obsolete)
2635 qq~SELECT DISTINCT vc.id, vc.name,
2636 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2638 JOIN $table vc ON (a.${table}_id = vc.id)
2639 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2641 push(@values, '%' . $self->{$table} . '%');
2644 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2646 $main::lxdebug->leave_sub();
2648 return scalar(@{ $self->{name_list} });
2651 # the selection sub is used in the AR, AP, IS, IR and OE module
2654 $main::lxdebug->enter_sub();
2656 my ($self, $myconfig, $table, $module) = @_;
2659 my $dbh = $self->get_standard_dbh;
2661 $table = $table eq "customer" ? "customer" : "vendor";
2663 my $query = qq|SELECT count(*) FROM $table|;
2664 my ($count) = selectrow_query($self, $dbh, $query);
2666 # build selection list
2667 if ($count <= $myconfig->{vclimit}) {
2668 $query = qq|SELECT id, name, salesman_id
2669 FROM $table WHERE NOT obsolete
2671 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2675 $self->get_employee($dbh);
2677 # setup sales contacts
2678 $query = qq|SELECT e.id, e.name
2680 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2681 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2684 push(@{ $self->{all_employees} },
2685 { id => $self->{employee_id},
2686 name => $self->{employee} });
2688 # sort the whole thing
2689 @{ $self->{all_employees} } =
2690 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2692 if ($module eq 'AR') {
2694 # prepare query for departments
2695 $query = qq|SELECT id, description
2698 ORDER BY description|;
2701 $query = qq|SELECT id, description
2703 ORDER BY description|;
2706 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2709 $query = qq|SELECT id, description
2713 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2716 $query = qq|SELECT printer_description, id
2718 ORDER BY printer_description|;
2720 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2723 $query = qq|SELECT id, description
2727 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2729 $main::lxdebug->leave_sub();
2732 sub language_payment {
2733 $main::lxdebug->enter_sub();
2735 my ($self, $myconfig) = @_;
2737 my $dbh = $self->get_standard_dbh($myconfig);
2739 my $query = qq|SELECT id, description
2743 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2746 $query = qq|SELECT printer_description, id
2748 ORDER BY printer_description|;
2750 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2753 $query = qq|SELECT id, description
2757 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2759 # get buchungsgruppen
2760 $query = qq|SELECT id, description
2761 FROM buchungsgruppen|;
2763 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2765 $main::lxdebug->leave_sub();
2768 # this is only used for reports
2769 sub all_departments {
2770 $main::lxdebug->enter_sub();
2772 my ($self, $myconfig, $table) = @_;
2774 my $dbh = $self->get_standard_dbh($myconfig);
2777 if ($table eq 'customer') {
2778 $where = "WHERE role = 'P' ";
2781 my $query = qq|SELECT id, description
2784 ORDER BY description|;
2785 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2787 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2789 $main::lxdebug->leave_sub();
2793 $main::lxdebug->enter_sub();
2795 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2798 if ($table eq "customer") {
2807 $self->all_vc($myconfig, $table, $module);
2809 # get last customers or vendors
2810 my ($query, $sth, $ref);
2812 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2817 my $transdate = "current_date";
2818 if ($self->{transdate}) {
2819 $transdate = $dbh->quote($self->{transdate});
2822 # now get the account numbers
2823 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2824 FROM chart c, taxkeys tk
2825 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2826 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2829 $sth = $dbh->prepare($query);
2831 do_statement($self, $sth, $query, '%' . $module . '%');
2833 $self->{accounts} = "";
2834 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2836 foreach my $key (split(/:/, $ref->{link})) {
2837 if ($key =~ /\Q$module\E/) {
2839 # cross reference for keys
2840 $xkeyref{ $ref->{accno} } = $key;
2842 push @{ $self->{"${module}_links"}{$key} },
2843 { accno => $ref->{accno},
2844 description => $ref->{description},
2845 taxkey => $ref->{taxkey_id},
2846 tax_id => $ref->{tax_id} };
2848 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2854 # get taxkeys and description
2855 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2856 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2858 if (($module eq "AP") || ($module eq "AR")) {
2859 # get tax rates and description
2860 $query = qq|SELECT * FROM tax|;
2861 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2867 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2868 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2869 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2870 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2872 d.description AS department,
2875 JOIN $table c ON (a.${table}_id = c.id)
2876 LEFT JOIN employee e ON (e.id = a.employee_id)
2877 LEFT JOIN department d ON (d.id = a.department_id)
2879 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2881 foreach my $key (keys %$ref) {
2882 $self->{$key} = $ref->{$key};
2885 my $transdate = "current_date";
2886 if ($self->{transdate}) {
2887 $transdate = $dbh->quote($self->{transdate});
2890 # now get the account numbers
2891 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2893 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2895 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2896 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2899 $sth = $dbh->prepare($query);
2900 do_statement($self, $sth, $query, "%$module%");
2902 $self->{accounts} = "";
2903 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2905 foreach my $key (split(/:/, $ref->{link})) {
2906 if ($key =~ /\Q$module\E/) {
2908 # cross reference for keys
2909 $xkeyref{ $ref->{accno} } = $key;
2911 push @{ $self->{"${module}_links"}{$key} },
2912 { accno => $ref->{accno},
2913 description => $ref->{description},
2914 taxkey => $ref->{taxkey_id},
2915 tax_id => $ref->{tax_id} };
2917 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2923 # get amounts from individual entries
2926 c.accno, c.description,
2927 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2931 LEFT JOIN chart c ON (c.id = a.chart_id)
2932 LEFT JOIN project p ON (p.id = a.project_id)
2933 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2934 WHERE (tk.taxkey_id=a.taxkey) AND
2935 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2936 THEN tk.chart_id = a.chart_id
2939 OR (c.link='%tax%')) AND
2940 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2941 WHERE a.trans_id = ?
2942 AND a.fx_transaction = '0'
2943 ORDER BY a.acc_trans_id, a.transdate|;
2944 $sth = $dbh->prepare($query);
2945 do_statement($self, $sth, $query, $self->{id});
2947 # get exchangerate for currency
2948 $self->{exchangerate} =
2949 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2952 # store amounts in {acc_trans}{$key} for multiple accounts
2953 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2954 $ref->{exchangerate} =
2955 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2956 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2959 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2960 $ref->{amount} *= -1;
2962 $ref->{index} = $index;
2964 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2970 d.curr AS currencies, d.closedto, d.revtrans,
2971 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2972 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2974 $ref = selectfirst_hashref_query($self, $dbh, $query);
2975 map { $self->{$_} = $ref->{$_} } keys %$ref;
2982 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2983 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2984 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2986 $ref = selectfirst_hashref_query($self, $dbh, $query);
2987 map { $self->{$_} = $ref->{$_} } keys %$ref;
2989 if ($self->{"$self->{vc}_id"}) {
2991 # only setup currency
2992 ($self->{currency}) = split(/:/, $self->{currencies});
2996 $self->lastname_used($dbh, $myconfig, $table, $module);
2998 # get exchangerate for currency
2999 $self->{exchangerate} =
3000 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3006 $main::lxdebug->leave_sub();
3010 $main::lxdebug->enter_sub();
3012 my ($self, $dbh, $myconfig, $table, $module) = @_;
3016 $table = $table eq "customer" ? "customer" : "vendor";
3017 my %column_map = ("a.curr" => "currency",
3018 "a.${table}_id" => "${table}_id",
3019 "a.department_id" => "department_id",
3020 "d.description" => "department",
3021 "ct.name" => $table,
3022 "current_date + ct.terms" => "duedate",
3025 if ($self->{type} =~ /delivery_order/) {
3026 $arap = 'delivery_orders';
3027 delete $column_map{"a.curr"};
3029 } elsif ($self->{type} =~ /_order/) {
3031 $where = "quotation = '0'";
3033 } elsif ($self->{type} =~ /_quotation/) {
3035 $where = "quotation = '1'";
3037 } elsif ($table eq 'customer') {
3045 $where = "($where) AND" if ($where);
3046 my $query = qq|SELECT MAX(id) FROM $arap
3047 WHERE $where ${table}_id > 0|;
3048 my ($trans_id) = selectrow_query($self, $dbh, $query);
3051 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3052 $query = qq|SELECT $column_spec
3054 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3055 LEFT JOIN department d ON (a.department_id = d.id)
3057 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3059 map { $self->{$_} = $ref->{$_} } values %column_map;
3061 $main::lxdebug->leave_sub();
3065 $main::lxdebug->enter_sub();
3068 my $myconfig = shift || \%::myconfig;
3069 my ($thisdate, $days) = @_;
3071 my $dbh = $self->get_standard_dbh($myconfig);
3076 my $dateformat = $myconfig->{dateformat};
3077 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3078 $thisdate = $dbh->quote($thisdate);
3079 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3081 $query = qq|SELECT current_date AS thisdate|;
3084 ($thisdate) = selectrow_query($self, $dbh, $query);
3086 $main::lxdebug->leave_sub();
3092 $main::lxdebug->enter_sub();
3094 my ($self, $string) = @_;
3096 if ($string !~ /%/) {
3097 $string = "%$string%";
3100 $string =~ s/\'/\'\'/g;
3102 $main::lxdebug->leave_sub();
3108 $main::lxdebug->enter_sub();
3110 my ($self, $flds, $new, $count, $numrows) = @_;
3114 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3119 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3121 my $j = $item->{ndx} - 1;
3122 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3126 for $i ($count + 1 .. $numrows) {
3127 map { delete $self->{"${_}_$i"} } @{$flds};
3130 $main::lxdebug->leave_sub();
3134 $main::lxdebug->enter_sub();
3136 my ($self, $myconfig) = @_;
3140 my $dbh = $self->dbconnect_noauto($myconfig);
3142 my $query = qq|DELETE FROM status
3143 WHERE (formname = ?) AND (trans_id = ?)|;
3144 my $sth = prepare_query($self, $dbh, $query);
3146 if ($self->{formname} =~ /(check|receipt)/) {
3147 for $i (1 .. $self->{rowcount}) {
3148 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3151 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3155 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3156 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3158 my %queued = split / /, $self->{queued};
3161 if ($self->{formname} =~ /(check|receipt)/) {
3163 # this is a check or receipt, add one entry for each lineitem
3164 my ($accno) = split /--/, $self->{account};
3165 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3166 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3167 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3168 $sth = prepare_query($self, $dbh, $query);
3170 for $i (1 .. $self->{rowcount}) {
3171 if ($self->{"checked_$i"}) {
3172 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3178 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3179 VALUES (?, ?, ?, ?, ?)|;
3180 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3181 $queued{$self->{formname}}, $self->{formname});
3187 $main::lxdebug->leave_sub();
3191 $main::lxdebug->enter_sub();
3193 my ($self, $dbh) = @_;
3195 my ($query, $printed, $emailed);
3197 my $formnames = $self->{printed};
3198 my $emailforms = $self->{emailed};
3200 $query = qq|DELETE FROM status
3201 WHERE (formname = ?) AND (trans_id = ?)|;
3202 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3204 # this only applies to the forms
3205 # checks and receipts are posted when printed or queued
3207 if ($self->{queued}) {
3208 my %queued = split / /, $self->{queued};
3210 foreach my $formname (keys %queued) {
3211 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3212 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3214 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3215 VALUES (?, ?, ?, ?, ?)|;
3216 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3218 $formnames =~ s/\Q$self->{formname}\E//;
3219 $emailforms =~ s/\Q$self->{formname}\E//;
3224 # save printed, emailed info
3225 $formnames =~ s/^ +//g;
3226 $emailforms =~ s/^ +//g;
3229 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3230 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3232 foreach my $formname (keys %status) {
3233 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3234 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3236 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3237 VALUES (?, ?, ?, ?)|;
3238 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3241 $main::lxdebug->leave_sub();
3245 # $main::locale->text('SAVED')
3246 # $main::locale->text('DELETED')
3247 # $main::locale->text('ADDED')
3248 # $main::locale->text('PAYMENT POSTED')
3249 # $main::locale->text('POSTED')
3250 # $main::locale->text('POSTED AS NEW')
3251 # $main::locale->text('ELSE')
3252 # $main::locale->text('SAVED FOR DUNNING')
3253 # $main::locale->text('DUNNING STARTED')
3254 # $main::locale->text('PRINTED')
3255 # $main::locale->text('MAILED')
3256 # $main::locale->text('SCREENED')
3257 # $main::locale->text('CANCELED')
3258 # $main::locale->text('invoice')
3259 # $main::locale->text('proforma')
3260 # $main::locale->text('sales_order')
3261 # $main::locale->text('pick_list')
3262 # $main::locale->text('purchase_order')
3263 # $main::locale->text('bin_list')
3264 # $main::locale->text('sales_quotation')
3265 # $main::locale->text('request_quotation')
3268 $main::lxdebug->enter_sub();
3271 my $dbh = shift || $self->get_standard_dbh;
3273 if(!exists $self->{employee_id}) {
3274 &get_employee($self, $dbh);
3278 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3279 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3280 my @values = (conv_i($self->{id}), $self->{login},
3281 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3282 do_query($self, $dbh, $query, @values);
3286 $main::lxdebug->leave_sub();
3290 $main::lxdebug->enter_sub();
3292 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3293 my ($orderBy, $desc) = split(/\-\-/, $order);
3294 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3297 if ($trans_id ne "") {
3299 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 | .
3300 qq|FROM history_erp h | .
3301 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3302 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3305 my $sth = $dbh->prepare($query) || $self->dberror($query);
3307 $sth->execute() || $self->dberror("$query");
3309 while(my $hash_ref = $sth->fetchrow_hashref()) {
3310 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3311 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3312 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3313 $tempArray[$i++] = $hash_ref;
3315 $main::lxdebug->leave_sub() and return \@tempArray
3316 if ($i > 0 && $tempArray[0] ne "");
3318 $main::lxdebug->leave_sub();
3322 sub update_defaults {
3323 $main::lxdebug->enter_sub();
3325 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3328 if ($provided_dbh) {
3329 $dbh = $provided_dbh;
3331 $dbh = $self->dbconnect_noauto($myconfig);
3333 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3334 my $sth = $dbh->prepare($query);
3336 $sth->execute || $self->dberror($query);
3337 my ($var) = $sth->fetchrow_array;
3340 if ($var =~ m/\d+$/) {
3341 my $new_var = (substr $var, $-[0]) * 1 + 1;
3342 my $len_diff = length($var) - $-[0] - length($new_var);
3343 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3349 $query = qq|UPDATE defaults SET $fld = ?|;
3350 do_query($self, $dbh, $query, $var);
3352 if (!$provided_dbh) {
3357 $main::lxdebug->leave_sub();
3362 sub update_business {
3363 $main::lxdebug->enter_sub();
3365 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3368 if ($provided_dbh) {
3369 $dbh = $provided_dbh;
3371 $dbh = $self->dbconnect_noauto($myconfig);
3374 qq|SELECT customernumberinit FROM business
3375 WHERE id = ? FOR UPDATE|;
3376 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3378 return undef unless $var;
3380 if ($var =~ m/\d+$/) {
3381 my $new_var = (substr $var, $-[0]) * 1 + 1;
3382 my $len_diff = length($var) - $-[0] - length($new_var);
3383 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3389 $query = qq|UPDATE business
3390 SET customernumberinit = ?
3392 do_query($self, $dbh, $query, $var, $business_id);
3394 if (!$provided_dbh) {
3399 $main::lxdebug->leave_sub();
3404 sub get_partsgroup {
3405 $main::lxdebug->enter_sub();
3407 my ($self, $myconfig, $p) = @_;
3408 my $target = $p->{target} || 'all_partsgroup';
3410 my $dbh = $self->get_standard_dbh($myconfig);
3412 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3414 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3417 if ($p->{searchitems} eq 'part') {
3418 $query .= qq|WHERE p.inventory_accno_id > 0|;
3420 if ($p->{searchitems} eq 'service') {
3421 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3423 if ($p->{searchitems} eq 'assembly') {
3424 $query .= qq|WHERE p.assembly = '1'|;
3426 if ($p->{searchitems} eq 'labor') {
3427 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3430 $query .= qq|ORDER BY partsgroup|;
3433 $query = qq|SELECT id, partsgroup FROM partsgroup
3434 ORDER BY partsgroup|;
3437 if ($p->{language_code}) {
3438 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3439 t.description AS translation
3441 JOIN parts p ON (p.partsgroup_id = pg.id)
3442 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3443 ORDER BY translation|;
3444 @values = ($p->{language_code});
3447 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3449 $main::lxdebug->leave_sub();
3452 sub get_pricegroup {
3453 $main::lxdebug->enter_sub();
3455 my ($self, $myconfig, $p) = @_;
3457 my $dbh = $self->get_standard_dbh($myconfig);
3459 my $query = qq|SELECT p.id, p.pricegroup
3462 $query .= qq| ORDER BY pricegroup|;
3465 $query = qq|SELECT id, pricegroup FROM pricegroup
3466 ORDER BY pricegroup|;
3469 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3471 $main::lxdebug->leave_sub();
3475 # usage $form->all_years($myconfig, [$dbh])
3476 # return list of all years where bookings found
3479 $main::lxdebug->enter_sub();
3481 my ($self, $myconfig, $dbh) = @_;
3483 $dbh ||= $self->get_standard_dbh($myconfig);
3486 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3487 (SELECT MAX(transdate) FROM acc_trans)|;
3488 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3490 if ($myconfig->{dateformat} =~ /^yy/) {
3491 ($startdate) = split /\W/, $startdate;
3492 ($enddate) = split /\W/, $enddate;
3494 (@_) = split /\W/, $startdate;
3496 (@_) = split /\W/, $enddate;
3501 $startdate = substr($startdate,0,4);
3502 $enddate = substr($enddate,0,4);
3504 while ($enddate >= $startdate) {
3505 push @all_years, $enddate--;
3510 $main::lxdebug->leave_sub();
3514 $main::lxdebug->enter_sub();
3518 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3520 $main::lxdebug->leave_sub();
3524 $main::lxdebug->enter_sub();
3529 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3531 $main::lxdebug->leave_sub();
3534 sub prepare_for_printing {
3537 $self->{templates} ||= $::myconfig{templates};
3538 $self->{formname} ||= $self->{type};
3539 $self->{media} ||= 'email';
3541 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3543 # set shipto from billto unless set
3544 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3545 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3546 $self->{shiptoname} = $::myconfig{company};
3547 $self->{shiptostreet} = $::myconfig{address};
3550 my $language = $self->{language} ? '_' . $self->{language} : '';
3552 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3553 if ($self->{language_id}) {
3554 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3556 $output_dateformat = $::myconfig{dateformat};
3557 $output_numberformat = $::myconfig{numberformat};
3558 $output_longdates = 1;
3561 # Retrieve accounts for tax calculation.
3562 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3564 if ($self->{type} =~ /_delivery_order$/) {
3565 DO->order_details();
3566 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3567 OE->order_details(\%::myconfig, $self);
3569 IS->invoice_details(\%::myconfig, $self, $::locale);
3572 # Chose extension & set source file name
3573 my $extension = 'html';
3574 if ($self->{format} eq 'postscript') {
3575 $self->{postscript} = 1;
3577 } elsif ($self->{"format"} =~ /pdf/) {
3579 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3580 } elsif ($self->{"format"} =~ /opendocument/) {
3581 $self->{opendocument} = 1;
3583 } elsif ($self->{"format"} =~ /excel/) {
3588 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3589 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3590 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3593 $self->format_dates($output_dateformat, $output_longdates,
3594 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3595 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3596 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3598 $self->reformat_numbers($output_numberformat, 2,
3599 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3600 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3602 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3604 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3606 if (scalar @{ $cvar_date_fields }) {
3607 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3610 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3611 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3618 my ($self, $dateformat, $longformat, @indices) = @_;
3620 $dateformat ||= $::myconfig{dateformat};
3622 foreach my $idx (@indices) {
3623 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3624 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3625 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3629 next unless defined $self->{$idx};
3631 if (!ref($self->{$idx})) {
3632 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3634 } elsif (ref($self->{$idx}) eq "ARRAY") {
3635 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3636 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3642 sub reformat_numbers {
3643 my ($self, $numberformat, $places, @indices) = @_;
3645 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3647 foreach my $idx (@indices) {
3648 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3649 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3650 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3654 next unless defined $self->{$idx};
3656 if (!ref($self->{$idx})) {
3657 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3659 } elsif (ref($self->{$idx}) eq "ARRAY") {
3660 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3661 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3666 my $saved_numberformat = $::myconfig{numberformat};
3667 $::myconfig{numberformat} = $numberformat;
3669 foreach my $idx (@indices) {
3670 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3671 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3672 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3676 next unless defined $self->{$idx};
3678 if (!ref($self->{$idx})) {
3679 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3681 } elsif (ref($self->{$idx}) eq "ARRAY") {
3682 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3683 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3688 $::myconfig{numberformat} = $saved_numberformat;
3697 SL::Form.pm - main data object.
3701 This is the main data object of Lx-Office.
3702 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3703 Points of interest for a beginner are:
3705 - $form->error - renders a generic error in html. accepts an error message
3706 - $form->get_standard_dbh - returns a database connection for the
3708 =head1 SPECIAL FUNCTIONS
3710 =head2 C<_store_value()>
3712 parses a complex var name, and stores it in the form.
3715 $form->_store_value($key, $value);
3717 keys must start with a string, and can contain various tokens.
3718 supported key structures are:
3721 simple key strings work as expected
3726 separating two keys by a dot (.) will result in a hash lookup for the inner value
3727 this is similar to the behaviour of java and templating mechanisms.
3729 filter.description => $form->{filter}->{description}
3731 3. array+hashref access
3733 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3734 using [+] instead of [] will force a new array index. this is useful for recurring
3735 data structures like part lists. put a [+] into the first varname, and use [] on the
3738 repeating these names in your template:
3741 invoice.items[].parts_id
3745 $form->{invoice}->{items}->[
3759 using brackets at the end of a name will result in a pure array to be created.
3760 note that you mustn't use [+], which is reserved for array+hash access and will
3761 result in undefined behaviour in array context.
3763 filter.status[] => $form->{status}->[ val1, val2, ... ]
3765 =head2 C<update_business> PARAMS
3768 \%config, - config hashref
3769 $business_id, - business id
3770 $dbh - optional database handle
3772 handles business (thats customer/vendor types) sequences.
3774 special behaviour for empty strings in customerinitnumber field:
3775 will in this case not increase the value, and return undef.
3777 =head2 C<redirect_header> $url
3779 Generates a HTTP redirection header for the new C<$url>. Constructs an
3780 absolute URL including scheme, host name and port. If C<$url> is a
3781 relative URL then it is considered relative to Lx-Office base URL.
3783 This function C<die>s if headers have already been created with
3784 C<$::form-E<gt>header>.
3788 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3789 print $::form->redirect_header('http://www.lx-office.org/');
3793 Generates a general purpose http/html header and includes most of the scripts
3794 ans stylesheets needed.
3796 Only one header will be generated. If the method was already called in this
3797 request it will not output anything and return undef. Also if no
3798 HTTP_USER_AGENT is found, no header is generated.
3800 Although header does not accept parameters itself, it will honor special
3801 hashkeys of its Form instance:
3809 If one of these is set, a http-equiv refresh is generated. Missing parameters
3810 default to 3 seconds and the refering url.
3816 If these are arrayrefs the contents will be inlined into the header.
3820 If true, a css snippet will be generated that sets the page in landscape mode.
3824 Used to override the default favicon.
3828 A html page title will be generated from this