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} : $!");
1364 $self->{copies} = 1 unless $self->{media} eq 'printer';
1366 chdir("$self->{cwd}");
1367 #print(STDERR "Kopien $self->{copies}\n");
1368 #print(STDERR "OUT $self->{OUT}\n");
1369 for my $i (1 .. $self->{copies}) {
1371 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1372 print OUT while <IN>;
1377 $self->{attachment_filename} = ($self->{attachment_filename})
1378 ? $self->{attachment_filename}
1379 : $self->generate_attachment_filename();
1381 # launch application
1382 print qq|Content-Type: | . $template->get_mime_type() . qq|
1383 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1384 Content-Length: $numbytes
1388 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1399 chdir("$self->{cwd}");
1400 $main::lxdebug->leave_sub();
1403 sub get_formname_translation {
1404 $main::lxdebug->enter_sub();
1405 my ($self, $formname) = @_;
1407 $formname ||= $self->{formname};
1409 my %formname_translations = (
1410 bin_list => $main::locale->text('Bin List'),
1411 credit_note => $main::locale->text('Credit Note'),
1412 invoice => $main::locale->text('Invoice'),
1413 pick_list => $main::locale->text('Pick List'),
1414 proforma => $main::locale->text('Proforma Invoice'),
1415 purchase_order => $main::locale->text('Purchase Order'),
1416 request_quotation => $main::locale->text('RFQ'),
1417 sales_order => $main::locale->text('Confirmation'),
1418 sales_quotation => $main::locale->text('Quotation'),
1419 storno_invoice => $main::locale->text('Storno Invoice'),
1420 sales_delivery_order => $main::locale->text('Delivery Order'),
1421 purchase_delivery_order => $main::locale->text('Delivery Order'),
1422 dunning => $main::locale->text('Dunning'),
1425 $main::lxdebug->leave_sub();
1426 return $formname_translations{$formname}
1429 sub get_number_prefix_for_type {
1430 $main::lxdebug->enter_sub();
1434 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1435 : ($self->{type} =~ /_quotation$/) ? 'quo'
1436 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1439 $main::lxdebug->leave_sub();
1443 sub get_extension_for_format {
1444 $main::lxdebug->enter_sub();
1447 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1448 : $self->{format} =~ /postscript/i ? ".ps"
1449 : $self->{format} =~ /opendocument/i ? ".odt"
1450 : $self->{format} =~ /excel/i ? ".xls"
1451 : $self->{format} =~ /html/i ? ".html"
1454 $main::lxdebug->leave_sub();
1458 sub generate_attachment_filename {
1459 $main::lxdebug->enter_sub();
1462 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1463 my $prefix = $self->get_number_prefix_for_type();
1465 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1466 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1468 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1469 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1472 $attachment_filename = "";
1475 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1476 $attachment_filename =~ s|[\s/\\]+|_|g;
1478 $main::lxdebug->leave_sub();
1479 return $attachment_filename;
1482 sub generate_email_subject {
1483 $main::lxdebug->enter_sub();
1486 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1487 my $prefix = $self->get_number_prefix_for_type();
1489 if ($subject && $self->{"${prefix}number"}) {
1490 $subject .= " " . $self->{"${prefix}number"}
1493 $main::lxdebug->leave_sub();
1498 $main::lxdebug->enter_sub();
1502 chdir("$self->{tmpdir}");
1505 if (-f "$self->{tmpfile}.err") {
1506 open(FH, "$self->{tmpfile}.err");
1511 if ($self->{tmpfile} && !($::lx_office_conf{debug} && $::lx_office_conf{debug}->{keep_temp_files})) {
1512 $self->{tmpfile} =~ s|.*/||g;
1514 $self->{tmpfile} =~ s/\.\w+$//g;
1515 my $tmpfile = $self->{tmpfile};
1516 unlink(<$tmpfile.*>);
1519 chdir("$self->{cwd}");
1521 $main::lxdebug->leave_sub();
1527 $main::lxdebug->enter_sub();
1529 my ($self, $date, $myconfig) = @_;
1532 if ($date && $date =~ /\D/) {
1534 if ($myconfig->{dateformat} =~ /^yy/) {
1535 ($yy, $mm, $dd) = split /\D/, $date;
1537 if ($myconfig->{dateformat} =~ /^mm/) {
1538 ($mm, $dd, $yy) = split /\D/, $date;
1540 if ($myconfig->{dateformat} =~ /^dd/) {
1541 ($dd, $mm, $yy) = split /\D/, $date;
1546 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1547 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1549 $dd = "0$dd" if ($dd < 10);
1550 $mm = "0$mm" if ($mm < 10);
1552 $date = "$yy$mm$dd";
1555 $main::lxdebug->leave_sub();
1560 # Database routines used throughout
1562 sub _dbconnect_options {
1564 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1571 $main::lxdebug->enter_sub(2);
1573 my ($self, $myconfig) = @_;
1575 # connect to database
1576 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1580 if ($myconfig->{dboptions}) {
1581 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1584 $main::lxdebug->leave_sub(2);
1589 sub dbconnect_noauto {
1590 $main::lxdebug->enter_sub();
1592 my ($self, $myconfig) = @_;
1594 # connect to database
1595 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1599 if ($myconfig->{dboptions}) {
1600 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1603 $main::lxdebug->leave_sub();
1608 sub get_standard_dbh {
1609 $main::lxdebug->enter_sub(2);
1612 my $myconfig = shift || \%::myconfig;
1614 if ($standard_dbh && !$standard_dbh->{Active}) {
1615 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1616 undef $standard_dbh;
1619 $standard_dbh ||= SL::DB::create->dbh;
1621 $main::lxdebug->leave_sub(2);
1623 return $standard_dbh;
1627 $main::lxdebug->enter_sub();
1629 my ($self, $date, $myconfig) = @_;
1630 my $dbh = $self->dbconnect($myconfig);
1632 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1633 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1634 my ($closed) = $sth->fetchrow_array;
1636 $main::lxdebug->leave_sub();
1641 sub update_balance {
1642 $main::lxdebug->enter_sub();
1644 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1646 # if we have a value, go do it
1649 # retrieve balance from table
1650 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1651 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1652 my ($balance) = $sth->fetchrow_array;
1658 $query = "UPDATE $table SET $field = $balance WHERE $where";
1659 do_query($self, $dbh, $query, @values);
1661 $main::lxdebug->leave_sub();
1664 sub update_exchangerate {
1665 $main::lxdebug->enter_sub();
1667 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1669 # some sanity check for currency
1671 $main::lxdebug->leave_sub();
1674 $query = qq|SELECT curr FROM defaults|;
1676 my ($currency) = selectrow_query($self, $dbh, $query);
1677 my ($defaultcurrency) = split m/:/, $currency;
1680 if ($curr eq $defaultcurrency) {
1681 $main::lxdebug->leave_sub();
1685 $query = qq|SELECT e.curr FROM exchangerate e
1686 WHERE e.curr = ? AND e.transdate = ?
1688 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1697 $buy = conv_i($buy, "NULL");
1698 $sell = conv_i($sell, "NULL");
1701 if ($buy != 0 && $sell != 0) {
1702 $set = "buy = $buy, sell = $sell";
1703 } elsif ($buy != 0) {
1704 $set = "buy = $buy";
1705 } elsif ($sell != 0) {
1706 $set = "sell = $sell";
1709 if ($sth->fetchrow_array) {
1710 $query = qq|UPDATE exchangerate
1716 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1717 VALUES (?, $buy, $sell, ?)|;
1720 do_query($self, $dbh, $query, $curr, $transdate);
1722 $main::lxdebug->leave_sub();
1725 sub save_exchangerate {
1726 $main::lxdebug->enter_sub();
1728 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1730 my $dbh = $self->dbconnect($myconfig);
1734 $buy = $rate if $fld eq 'buy';
1735 $sell = $rate if $fld eq 'sell';
1738 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1743 $main::lxdebug->leave_sub();
1746 sub get_exchangerate {
1747 $main::lxdebug->enter_sub();
1749 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1752 unless ($transdate) {
1753 $main::lxdebug->leave_sub();
1757 $query = qq|SELECT curr FROM defaults|;
1759 my ($currency) = selectrow_query($self, $dbh, $query);
1760 my ($defaultcurrency) = split m/:/, $currency;
1762 if ($currency eq $defaultcurrency) {
1763 $main::lxdebug->leave_sub();
1767 $query = qq|SELECT e.$fld FROM exchangerate e
1768 WHERE e.curr = ? AND e.transdate = ?|;
1769 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1773 $main::lxdebug->leave_sub();
1775 return $exchangerate;
1778 sub check_exchangerate {
1779 $main::lxdebug->enter_sub();
1781 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1783 if ($fld !~/^buy|sell$/) {
1784 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1787 unless ($transdate) {
1788 $main::lxdebug->leave_sub();
1792 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1794 if ($currency eq $defaultcurrency) {
1795 $main::lxdebug->leave_sub();
1799 my $dbh = $self->get_standard_dbh($myconfig);
1800 my $query = qq|SELECT e.$fld FROM exchangerate e
1801 WHERE e.curr = ? AND e.transdate = ?|;
1803 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1805 $main::lxdebug->leave_sub();
1807 return $exchangerate;
1810 sub get_all_currencies {
1811 $main::lxdebug->enter_sub();
1814 my $myconfig = shift || \%::myconfig;
1815 my $dbh = $self->get_standard_dbh($myconfig);
1817 my $query = qq|SELECT curr FROM defaults|;
1819 my ($curr) = selectrow_query($self, $dbh, $query);
1820 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1822 $main::lxdebug->leave_sub();
1827 sub get_default_currency {
1828 $main::lxdebug->enter_sub();
1830 my ($self, $myconfig) = @_;
1831 my @currencies = $self->get_all_currencies($myconfig);
1833 $main::lxdebug->leave_sub();
1835 return $currencies[0];
1838 sub set_payment_options {
1839 $main::lxdebug->enter_sub();
1841 my ($self, $myconfig, $transdate) = @_;
1843 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1845 my $dbh = $self->get_standard_dbh($myconfig);
1848 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1849 qq|FROM payment_terms p | .
1852 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1853 $self->{payment_terms}) =
1854 selectrow_query($self, $dbh, $query, $self->{payment_id});
1856 if ($transdate eq "") {
1857 if ($self->{invdate}) {
1858 $transdate = $self->{invdate};
1860 $transdate = $self->{transdate};
1865 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1866 qq|FROM payment_terms|;
1867 ($self->{netto_date}, $self->{skonto_date}) =
1868 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1870 my ($invtotal, $total);
1871 my (%amounts, %formatted_amounts);
1873 if ($self->{type} =~ /_order$/) {
1874 $amounts{invtotal} = $self->{ordtotal};
1875 $amounts{total} = $self->{ordtotal};
1877 } elsif ($self->{type} =~ /_quotation$/) {
1878 $amounts{invtotal} = $self->{quototal};
1879 $amounts{total} = $self->{quototal};
1882 $amounts{invtotal} = $self->{invtotal};
1883 $amounts{total} = $self->{total};
1885 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1887 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1889 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1890 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1891 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1893 foreach (keys %amounts) {
1894 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1895 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1898 if ($self->{"language_id"}) {
1900 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1901 qq|FROM translation_payment_terms t | .
1902 qq|LEFT JOIN language l ON t.language_id = l.id | .
1903 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1904 my ($description_long, $output_numberformat, $output_dateformat,
1905 $output_longdates) =
1906 selectrow_query($self, $dbh, $query,
1907 $self->{"language_id"}, $self->{"payment_id"});
1909 $self->{payment_terms} = $description_long if ($description_long);
1911 if ($output_dateformat) {
1912 foreach my $key (qw(netto_date skonto_date)) {
1914 $main::locale->reformat_date($myconfig, $self->{$key},
1920 if ($output_numberformat &&
1921 ($output_numberformat ne $myconfig->{"numberformat"})) {
1922 my $saved_numberformat = $myconfig->{"numberformat"};
1923 $myconfig->{"numberformat"} = $output_numberformat;
1924 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1925 $myconfig->{"numberformat"} = $saved_numberformat;
1929 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1930 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1931 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1932 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1933 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1934 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1935 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1937 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1939 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1941 $main::lxdebug->leave_sub();
1945 sub get_template_language {
1946 $main::lxdebug->enter_sub();
1948 my ($self, $myconfig) = @_;
1950 my $template_code = "";
1952 if ($self->{language_id}) {
1953 my $dbh = $self->get_standard_dbh($myconfig);
1954 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1955 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1958 $main::lxdebug->leave_sub();
1960 return $template_code;
1963 sub get_printer_code {
1964 $main::lxdebug->enter_sub();
1966 my ($self, $myconfig) = @_;
1968 my $template_code = "";
1970 if ($self->{printer_id}) {
1971 my $dbh = $self->get_standard_dbh($myconfig);
1972 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1973 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1976 $main::lxdebug->leave_sub();
1978 return $template_code;
1982 $main::lxdebug->enter_sub();
1984 my ($self, $myconfig) = @_;
1986 my $template_code = "";
1988 if ($self->{shipto_id}) {
1989 my $dbh = $self->get_standard_dbh($myconfig);
1990 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1991 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1992 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1995 $main::lxdebug->leave_sub();
1999 $main::lxdebug->enter_sub();
2001 my ($self, $dbh, $id, $module) = @_;
2006 foreach my $item (qw(name department_1 department_2 street zipcode city country
2007 contact cp_gender phone fax email)) {
2008 if ($self->{"shipto$item"}) {
2009 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
2011 push(@values, $self->{"shipto${item}"});
2015 if ($self->{shipto_id}) {
2016 my $query = qq|UPDATE shipto set
2018 shiptodepartment_1 = ?,
2019 shiptodepartment_2 = ?,
2025 shiptocp_gender = ?,
2029 WHERE shipto_id = ?|;
2030 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2032 my $query = qq|SELECT * FROM shipto
2033 WHERE shiptoname = ? AND
2034 shiptodepartment_1 = ? AND
2035 shiptodepartment_2 = ? AND
2036 shiptostreet = ? AND
2037 shiptozipcode = ? AND
2039 shiptocountry = ? AND
2040 shiptocontact = ? AND
2041 shiptocp_gender = ? AND
2047 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2050 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2051 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2052 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2053 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2054 do_query($self, $dbh, $query, $id, @values, $module);
2059 $main::lxdebug->leave_sub();
2063 $main::lxdebug->enter_sub();
2065 my ($self, $dbh) = @_;
2067 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2069 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2070 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2071 $self->{"employee_id"} *= 1;
2073 $main::lxdebug->leave_sub();
2076 sub get_employee_data {
2077 $main::lxdebug->enter_sub();
2082 Common::check_params(\%params, qw(prefix));
2083 Common::check_params_x(\%params, qw(id));
2086 $main::lxdebug->leave_sub();
2090 my $myconfig = \%main::myconfig;
2091 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2093 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2096 my $user = User->new($login);
2097 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2099 $self->{$params{prefix} . '_login'} = $login;
2100 $self->{$params{prefix} . '_name'} ||= $login;
2103 $main::lxdebug->leave_sub();
2107 $main::lxdebug->enter_sub();
2109 my ($self, $myconfig, $reference_date) = @_;
2111 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2113 my $dbh = $self->get_standard_dbh($myconfig);
2114 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2115 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2117 $main::lxdebug->leave_sub();
2123 $main::lxdebug->enter_sub();
2125 my ($self, $dbh, $id, $key) = @_;
2127 $key = "all_contacts" unless ($key);
2131 $main::lxdebug->leave_sub();
2136 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2137 qq|FROM contacts | .
2138 qq|WHERE cp_cv_id = ? | .
2139 qq|ORDER BY lower(cp_name)|;
2141 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2143 $main::lxdebug->leave_sub();
2147 $main::lxdebug->enter_sub();
2149 my ($self, $dbh, $key) = @_;
2151 my ($all, $old_id, $where, @values);
2153 if (ref($key) eq "HASH") {
2156 $key = "ALL_PROJECTS";
2158 foreach my $p (keys(%{$params})) {
2160 $all = $params->{$p};
2161 } elsif ($p eq "old_id") {
2162 $old_id = $params->{$p};
2163 } elsif ($p eq "key") {
2164 $key = $params->{$p};
2170 $where = "WHERE active ";
2172 if (ref($old_id) eq "ARRAY") {
2173 my @ids = grep({ $_ } @{$old_id});
2175 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2176 push(@values, @ids);
2179 $where .= " OR (id = ?) ";
2180 push(@values, $old_id);
2186 qq|SELECT id, projectnumber, description, active | .
2189 qq|ORDER BY lower(projectnumber)|;
2191 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2193 $main::lxdebug->leave_sub();
2197 $main::lxdebug->enter_sub();
2199 my ($self, $dbh, $vc_id, $key) = @_;
2201 $key = "all_shipto" unless ($key);
2204 # get shipping addresses
2205 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2207 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2213 $main::lxdebug->leave_sub();
2217 $main::lxdebug->enter_sub();
2219 my ($self, $dbh, $key) = @_;
2221 $key = "all_printers" unless ($key);
2223 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2225 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2227 $main::lxdebug->leave_sub();
2231 $main::lxdebug->enter_sub();
2233 my ($self, $dbh, $params) = @_;
2236 $key = $params->{key};
2237 $key = "all_charts" unless ($key);
2239 my $transdate = quote_db_date($params->{transdate});
2242 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2244 qq|LEFT JOIN taxkeys tk ON | .
2245 qq|(tk.id = (SELECT id FROM taxkeys | .
2246 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2247 qq| ORDER BY startdate DESC LIMIT 1)) | .
2248 qq|ORDER BY c.accno|;
2250 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2252 $main::lxdebug->leave_sub();
2255 sub _get_taxcharts {
2256 $main::lxdebug->enter_sub();
2258 my ($self, $dbh, $params) = @_;
2260 my $key = "all_taxcharts";
2263 if (ref $params eq 'HASH') {
2264 $key = $params->{key} if ($params->{key});
2265 if ($params->{module} eq 'AR') {
2266 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2268 } elsif ($params->{module} eq 'AP') {
2269 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2276 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2278 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2280 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2282 $main::lxdebug->leave_sub();
2286 $main::lxdebug->enter_sub();
2288 my ($self, $dbh, $key) = @_;
2290 $key = "all_taxzones" unless ($key);
2292 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2294 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2296 $main::lxdebug->leave_sub();
2299 sub _get_employees {
2300 $main::lxdebug->enter_sub();
2302 my ($self, $dbh, $default_key, $key) = @_;
2304 $key = $default_key unless ($key);
2305 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2307 $main::lxdebug->leave_sub();
2310 sub _get_business_types {
2311 $main::lxdebug->enter_sub();
2313 my ($self, $dbh, $key) = @_;
2315 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2316 $options->{key} ||= "all_business_types";
2319 if (exists $options->{salesman}) {
2320 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2323 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2325 $main::lxdebug->leave_sub();
2328 sub _get_languages {
2329 $main::lxdebug->enter_sub();
2331 my ($self, $dbh, $key) = @_;
2333 $key = "all_languages" unless ($key);
2335 my $query = qq|SELECT * FROM language ORDER BY id|;
2337 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2339 $main::lxdebug->leave_sub();
2342 sub _get_dunning_configs {
2343 $main::lxdebug->enter_sub();
2345 my ($self, $dbh, $key) = @_;
2347 $key = "all_dunning_configs" unless ($key);
2349 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2351 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2353 $main::lxdebug->leave_sub();
2356 sub _get_currencies {
2357 $main::lxdebug->enter_sub();
2359 my ($self, $dbh, $key) = @_;
2361 $key = "all_currencies" unless ($key);
2363 my $query = qq|SELECT curr AS currency FROM defaults|;
2365 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2367 $main::lxdebug->leave_sub();
2371 $main::lxdebug->enter_sub();
2373 my ($self, $dbh, $key) = @_;
2375 $key = "all_payments" unless ($key);
2377 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2379 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2381 $main::lxdebug->leave_sub();
2384 sub _get_customers {
2385 $main::lxdebug->enter_sub();
2387 my ($self, $dbh, $key) = @_;
2389 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2390 $options->{key} ||= "all_customers";
2391 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2394 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2395 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2396 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2398 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2399 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2401 $main::lxdebug->leave_sub();
2405 $main::lxdebug->enter_sub();
2407 my ($self, $dbh, $key) = @_;
2409 $key = "all_vendors" unless ($key);
2411 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2413 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2415 $main::lxdebug->leave_sub();
2418 sub _get_departments {
2419 $main::lxdebug->enter_sub();
2421 my ($self, $dbh, $key) = @_;
2423 $key = "all_departments" unless ($key);
2425 my $query = qq|SELECT * FROM department ORDER BY description|;
2427 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2429 $main::lxdebug->leave_sub();
2432 sub _get_warehouses {
2433 $main::lxdebug->enter_sub();
2435 my ($self, $dbh, $param) = @_;
2437 my ($key, $bins_key);
2439 if ('' eq ref $param) {
2443 $key = $param->{key};
2444 $bins_key = $param->{bins};
2447 my $query = qq|SELECT w.* FROM warehouse w
2448 WHERE (NOT w.invalid) AND
2449 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2450 ORDER BY w.sortkey|;
2452 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2455 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2456 my $sth = prepare_query($self, $dbh, $query);
2458 foreach my $warehouse (@{ $self->{$key} }) {
2459 do_statement($self, $sth, $query, $warehouse->{id});
2460 $warehouse->{$bins_key} = [];
2462 while (my $ref = $sth->fetchrow_hashref()) {
2463 push @{ $warehouse->{$bins_key} }, $ref;
2469 $main::lxdebug->leave_sub();
2473 $main::lxdebug->enter_sub();
2475 my ($self, $dbh, $table, $key, $sortkey) = @_;
2477 my $query = qq|SELECT * FROM $table|;
2478 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2480 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2482 $main::lxdebug->leave_sub();
2486 # $main::lxdebug->enter_sub();
2488 # my ($self, $dbh, $key) = @_;
2490 # $key ||= "all_groups";
2492 # my $groups = $main::auth->read_groups();
2494 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2496 # $main::lxdebug->leave_sub();
2500 $main::lxdebug->enter_sub();
2505 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2506 my ($sth, $query, $ref);
2508 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2509 my $vc_id = $self->{"${vc}_id"};
2511 if ($params{"contacts"}) {
2512 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2515 if ($params{"shipto"}) {
2516 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2519 if ($params{"projects"} || $params{"all_projects"}) {
2520 $self->_get_projects($dbh, $params{"all_projects"} ?
2521 $params{"all_projects"} : $params{"projects"},
2522 $params{"all_projects"} ? 1 : 0);
2525 if ($params{"printers"}) {
2526 $self->_get_printers($dbh, $params{"printers"});
2529 if ($params{"languages"}) {
2530 $self->_get_languages($dbh, $params{"languages"});
2533 if ($params{"charts"}) {
2534 $self->_get_charts($dbh, $params{"charts"});
2537 if ($params{"taxcharts"}) {
2538 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2541 if ($params{"taxzones"}) {
2542 $self->_get_taxzones($dbh, $params{"taxzones"});
2545 if ($params{"employees"}) {
2546 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2549 if ($params{"salesmen"}) {
2550 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2553 if ($params{"business_types"}) {
2554 $self->_get_business_types($dbh, $params{"business_types"});
2557 if ($params{"dunning_configs"}) {
2558 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2561 if($params{"currencies"}) {
2562 $self->_get_currencies($dbh, $params{"currencies"});
2565 if($params{"customers"}) {
2566 $self->_get_customers($dbh, $params{"customers"});
2569 if($params{"vendors"}) {
2570 if (ref $params{"vendors"} eq 'HASH') {
2571 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2573 $self->_get_vendors($dbh, $params{"vendors"});
2577 if($params{"payments"}) {
2578 $self->_get_payments($dbh, $params{"payments"});
2581 if($params{"departments"}) {
2582 $self->_get_departments($dbh, $params{"departments"});
2585 if ($params{price_factors}) {
2586 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2589 if ($params{warehouses}) {
2590 $self->_get_warehouses($dbh, $params{warehouses});
2593 # if ($params{groups}) {
2594 # $self->_get_groups($dbh, $params{groups});
2597 if ($params{partsgroup}) {
2598 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2601 $main::lxdebug->leave_sub();
2604 # this sub gets the id and name from $table
2606 $main::lxdebug->enter_sub();
2608 my ($self, $myconfig, $table) = @_;
2610 # connect to database
2611 my $dbh = $self->get_standard_dbh($myconfig);
2613 $table = $table eq "customer" ? "customer" : "vendor";
2614 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2616 my ($query, @values);
2618 if (!$self->{openinvoices}) {
2620 if ($self->{customernumber} ne "") {
2621 $where = qq|(vc.customernumber ILIKE ?)|;
2622 push(@values, '%' . $self->{customernumber} . '%');
2624 $where = qq|(vc.name ILIKE ?)|;
2625 push(@values, '%' . $self->{$table} . '%');
2629 qq~SELECT vc.id, vc.name,
2630 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2632 WHERE $where AND (NOT vc.obsolete)
2636 qq~SELECT DISTINCT vc.id, vc.name,
2637 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2639 JOIN $table vc ON (a.${table}_id = vc.id)
2640 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2642 push(@values, '%' . $self->{$table} . '%');
2645 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2647 $main::lxdebug->leave_sub();
2649 return scalar(@{ $self->{name_list} });
2652 # the selection sub is used in the AR, AP, IS, IR and OE module
2655 $main::lxdebug->enter_sub();
2657 my ($self, $myconfig, $table, $module) = @_;
2660 my $dbh = $self->get_standard_dbh;
2662 $table = $table eq "customer" ? "customer" : "vendor";
2664 my $query = qq|SELECT count(*) FROM $table|;
2665 my ($count) = selectrow_query($self, $dbh, $query);
2667 # build selection list
2668 if ($count <= $myconfig->{vclimit}) {
2669 $query = qq|SELECT id, name, salesman_id
2670 FROM $table WHERE NOT obsolete
2672 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2676 $self->get_employee($dbh);
2678 # setup sales contacts
2679 $query = qq|SELECT e.id, e.name
2681 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2682 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2685 push(@{ $self->{all_employees} },
2686 { id => $self->{employee_id},
2687 name => $self->{employee} });
2689 # sort the whole thing
2690 @{ $self->{all_employees} } =
2691 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2693 if ($module eq 'AR') {
2695 # prepare query for departments
2696 $query = qq|SELECT id, description
2699 ORDER BY description|;
2702 $query = qq|SELECT id, description
2704 ORDER BY description|;
2707 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2710 $query = qq|SELECT id, description
2714 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2717 $query = qq|SELECT printer_description, id
2719 ORDER BY printer_description|;
2721 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2724 $query = qq|SELECT id, description
2728 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2730 $main::lxdebug->leave_sub();
2733 sub language_payment {
2734 $main::lxdebug->enter_sub();
2736 my ($self, $myconfig) = @_;
2738 my $dbh = $self->get_standard_dbh($myconfig);
2740 my $query = qq|SELECT id, description
2744 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2747 $query = qq|SELECT printer_description, id
2749 ORDER BY printer_description|;
2751 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2754 $query = qq|SELECT id, description
2758 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2760 # get buchungsgruppen
2761 $query = qq|SELECT id, description
2762 FROM buchungsgruppen|;
2764 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2766 $main::lxdebug->leave_sub();
2769 # this is only used for reports
2770 sub all_departments {
2771 $main::lxdebug->enter_sub();
2773 my ($self, $myconfig, $table) = @_;
2775 my $dbh = $self->get_standard_dbh($myconfig);
2778 if ($table eq 'customer') {
2779 $where = "WHERE role = 'P' ";
2782 my $query = qq|SELECT id, description
2785 ORDER BY description|;
2786 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2788 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2790 $main::lxdebug->leave_sub();
2794 $main::lxdebug->enter_sub();
2796 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2799 if ($table eq "customer") {
2808 $self->all_vc($myconfig, $table, $module);
2810 # get last customers or vendors
2811 my ($query, $sth, $ref);
2813 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2818 my $transdate = "current_date";
2819 if ($self->{transdate}) {
2820 $transdate = $dbh->quote($self->{transdate});
2823 # now get the account numbers
2824 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2825 FROM chart c, taxkeys tk
2826 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2827 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2830 $sth = $dbh->prepare($query);
2832 do_statement($self, $sth, $query, '%' . $module . '%');
2834 $self->{accounts} = "";
2835 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2837 foreach my $key (split(/:/, $ref->{link})) {
2838 if ($key =~ /\Q$module\E/) {
2840 # cross reference for keys
2841 $xkeyref{ $ref->{accno} } = $key;
2843 push @{ $self->{"${module}_links"}{$key} },
2844 { accno => $ref->{accno},
2845 description => $ref->{description},
2846 taxkey => $ref->{taxkey_id},
2847 tax_id => $ref->{tax_id} };
2849 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2855 # get taxkeys and description
2856 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2857 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2859 if (($module eq "AP") || ($module eq "AR")) {
2860 # get tax rates and description
2861 $query = qq|SELECT * FROM tax|;
2862 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2868 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2869 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2870 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2871 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2873 d.description AS department,
2876 JOIN $table c ON (a.${table}_id = c.id)
2877 LEFT JOIN employee e ON (e.id = a.employee_id)
2878 LEFT JOIN department d ON (d.id = a.department_id)
2880 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2882 foreach my $key (keys %$ref) {
2883 $self->{$key} = $ref->{$key};
2886 my $transdate = "current_date";
2887 if ($self->{transdate}) {
2888 $transdate = $dbh->quote($self->{transdate});
2891 # now get the account numbers
2892 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2894 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2896 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2897 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2900 $sth = $dbh->prepare($query);
2901 do_statement($self, $sth, $query, "%$module%");
2903 $self->{accounts} = "";
2904 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2906 foreach my $key (split(/:/, $ref->{link})) {
2907 if ($key =~ /\Q$module\E/) {
2909 # cross reference for keys
2910 $xkeyref{ $ref->{accno} } = $key;
2912 push @{ $self->{"${module}_links"}{$key} },
2913 { accno => $ref->{accno},
2914 description => $ref->{description},
2915 taxkey => $ref->{taxkey_id},
2916 tax_id => $ref->{tax_id} };
2918 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2924 # get amounts from individual entries
2927 c.accno, c.description,
2928 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2932 LEFT JOIN chart c ON (c.id = a.chart_id)
2933 LEFT JOIN project p ON (p.id = a.project_id)
2934 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2935 WHERE (tk.taxkey_id=a.taxkey) AND
2936 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2937 THEN tk.chart_id = a.chart_id
2940 OR (c.link='%tax%')) AND
2941 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2942 WHERE a.trans_id = ?
2943 AND a.fx_transaction = '0'
2944 ORDER BY a.acc_trans_id, a.transdate|;
2945 $sth = $dbh->prepare($query);
2946 do_statement($self, $sth, $query, $self->{id});
2948 # get exchangerate for currency
2949 $self->{exchangerate} =
2950 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2953 # store amounts in {acc_trans}{$key} for multiple accounts
2954 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2955 $ref->{exchangerate} =
2956 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2957 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2960 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2961 $ref->{amount} *= -1;
2963 $ref->{index} = $index;
2965 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2971 d.curr AS currencies, d.closedto, d.revtrans,
2972 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2973 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2975 $ref = selectfirst_hashref_query($self, $dbh, $query);
2976 map { $self->{$_} = $ref->{$_} } keys %$ref;
2983 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2984 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2985 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2987 $ref = selectfirst_hashref_query($self, $dbh, $query);
2988 map { $self->{$_} = $ref->{$_} } keys %$ref;
2990 if ($self->{"$self->{vc}_id"}) {
2992 # only setup currency
2993 ($self->{currency}) = split(/:/, $self->{currencies});
2997 $self->lastname_used($dbh, $myconfig, $table, $module);
2999 # get exchangerate for currency
3000 $self->{exchangerate} =
3001 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
3007 $main::lxdebug->leave_sub();
3011 $main::lxdebug->enter_sub();
3013 my ($self, $dbh, $myconfig, $table, $module) = @_;
3017 $table = $table eq "customer" ? "customer" : "vendor";
3018 my %column_map = ("a.curr" => "currency",
3019 "a.${table}_id" => "${table}_id",
3020 "a.department_id" => "department_id",
3021 "d.description" => "department",
3022 "ct.name" => $table,
3023 "current_date + ct.terms" => "duedate",
3026 if ($self->{type} =~ /delivery_order/) {
3027 $arap = 'delivery_orders';
3028 delete $column_map{"a.curr"};
3030 } elsif ($self->{type} =~ /_order/) {
3032 $where = "quotation = '0'";
3034 } elsif ($self->{type} =~ /_quotation/) {
3036 $where = "quotation = '1'";
3038 } elsif ($table eq 'customer') {
3046 $where = "($where) AND" if ($where);
3047 my $query = qq|SELECT MAX(id) FROM $arap
3048 WHERE $where ${table}_id > 0|;
3049 my ($trans_id) = selectrow_query($self, $dbh, $query);
3052 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3053 $query = qq|SELECT $column_spec
3055 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3056 LEFT JOIN department d ON (a.department_id = d.id)
3058 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3060 map { $self->{$_} = $ref->{$_} } values %column_map;
3062 $main::lxdebug->leave_sub();
3066 $main::lxdebug->enter_sub();
3069 my $myconfig = shift || \%::myconfig;
3070 my ($thisdate, $days) = @_;
3072 my $dbh = $self->get_standard_dbh($myconfig);
3077 my $dateformat = $myconfig->{dateformat};
3078 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3079 $thisdate = $dbh->quote($thisdate);
3080 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3082 $query = qq|SELECT current_date AS thisdate|;
3085 ($thisdate) = selectrow_query($self, $dbh, $query);
3087 $main::lxdebug->leave_sub();
3093 $main::lxdebug->enter_sub();
3095 my ($self, $string) = @_;
3097 if ($string !~ /%/) {
3098 $string = "%$string%";
3101 $string =~ s/\'/\'\'/g;
3103 $main::lxdebug->leave_sub();
3109 $main::lxdebug->enter_sub();
3111 my ($self, $flds, $new, $count, $numrows) = @_;
3115 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3120 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3122 my $j = $item->{ndx} - 1;
3123 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3127 for $i ($count + 1 .. $numrows) {
3128 map { delete $self->{"${_}_$i"} } @{$flds};
3131 $main::lxdebug->leave_sub();
3135 $main::lxdebug->enter_sub();
3137 my ($self, $myconfig) = @_;
3141 my $dbh = $self->dbconnect_noauto($myconfig);
3143 my $query = qq|DELETE FROM status
3144 WHERE (formname = ?) AND (trans_id = ?)|;
3145 my $sth = prepare_query($self, $dbh, $query);
3147 if ($self->{formname} =~ /(check|receipt)/) {
3148 for $i (1 .. $self->{rowcount}) {
3149 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3152 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3156 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3157 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3159 my %queued = split / /, $self->{queued};
3162 if ($self->{formname} =~ /(check|receipt)/) {
3164 # this is a check or receipt, add one entry for each lineitem
3165 my ($accno) = split /--/, $self->{account};
3166 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3167 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3168 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3169 $sth = prepare_query($self, $dbh, $query);
3171 for $i (1 .. $self->{rowcount}) {
3172 if ($self->{"checked_$i"}) {
3173 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3179 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3180 VALUES (?, ?, ?, ?, ?)|;
3181 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3182 $queued{$self->{formname}}, $self->{formname});
3188 $main::lxdebug->leave_sub();
3192 $main::lxdebug->enter_sub();
3194 my ($self, $dbh) = @_;
3196 my ($query, $printed, $emailed);
3198 my $formnames = $self->{printed};
3199 my $emailforms = $self->{emailed};
3201 $query = qq|DELETE FROM status
3202 WHERE (formname = ?) AND (trans_id = ?)|;
3203 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3205 # this only applies to the forms
3206 # checks and receipts are posted when printed or queued
3208 if ($self->{queued}) {
3209 my %queued = split / /, $self->{queued};
3211 foreach my $formname (keys %queued) {
3212 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3213 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3215 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3216 VALUES (?, ?, ?, ?, ?)|;
3217 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3219 $formnames =~ s/\Q$self->{formname}\E//;
3220 $emailforms =~ s/\Q$self->{formname}\E//;
3225 # save printed, emailed info
3226 $formnames =~ s/^ +//g;
3227 $emailforms =~ s/^ +//g;
3230 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3231 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3233 foreach my $formname (keys %status) {
3234 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3235 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3237 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3238 VALUES (?, ?, ?, ?)|;
3239 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3242 $main::lxdebug->leave_sub();
3246 # $main::locale->text('SAVED')
3247 # $main::locale->text('DELETED')
3248 # $main::locale->text('ADDED')
3249 # $main::locale->text('PAYMENT POSTED')
3250 # $main::locale->text('POSTED')
3251 # $main::locale->text('POSTED AS NEW')
3252 # $main::locale->text('ELSE')
3253 # $main::locale->text('SAVED FOR DUNNING')
3254 # $main::locale->text('DUNNING STARTED')
3255 # $main::locale->text('PRINTED')
3256 # $main::locale->text('MAILED')
3257 # $main::locale->text('SCREENED')
3258 # $main::locale->text('CANCELED')
3259 # $main::locale->text('invoice')
3260 # $main::locale->text('proforma')
3261 # $main::locale->text('sales_order')
3262 # $main::locale->text('pick_list')
3263 # $main::locale->text('purchase_order')
3264 # $main::locale->text('bin_list')
3265 # $main::locale->text('sales_quotation')
3266 # $main::locale->text('request_quotation')
3269 $main::lxdebug->enter_sub();
3272 my $dbh = shift || $self->get_standard_dbh;
3274 if(!exists $self->{employee_id}) {
3275 &get_employee($self, $dbh);
3279 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3280 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3281 my @values = (conv_i($self->{id}), $self->{login},
3282 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3283 do_query($self, $dbh, $query, @values);
3287 $main::lxdebug->leave_sub();
3291 $main::lxdebug->enter_sub();
3293 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3294 my ($orderBy, $desc) = split(/\-\-/, $order);
3295 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3298 if ($trans_id ne "") {
3300 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 | .
3301 qq|FROM history_erp h | .
3302 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3303 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3306 my $sth = $dbh->prepare($query) || $self->dberror($query);
3308 $sth->execute() || $self->dberror("$query");
3310 while(my $hash_ref = $sth->fetchrow_hashref()) {
3311 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3312 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3313 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3314 $tempArray[$i++] = $hash_ref;
3316 $main::lxdebug->leave_sub() and return \@tempArray
3317 if ($i > 0 && $tempArray[0] ne "");
3319 $main::lxdebug->leave_sub();
3323 sub update_defaults {
3324 $main::lxdebug->enter_sub();
3326 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3329 if ($provided_dbh) {
3330 $dbh = $provided_dbh;
3332 $dbh = $self->dbconnect_noauto($myconfig);
3334 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3335 my $sth = $dbh->prepare($query);
3337 $sth->execute || $self->dberror($query);
3338 my ($var) = $sth->fetchrow_array;
3341 if ($var =~ m/\d+$/) {
3342 my $new_var = (substr $var, $-[0]) * 1 + 1;
3343 my $len_diff = length($var) - $-[0] - length($new_var);
3344 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3350 $query = qq|UPDATE defaults SET $fld = ?|;
3351 do_query($self, $dbh, $query, $var);
3353 if (!$provided_dbh) {
3358 $main::lxdebug->leave_sub();
3363 sub update_business {
3364 $main::lxdebug->enter_sub();
3366 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3369 if ($provided_dbh) {
3370 $dbh = $provided_dbh;
3372 $dbh = $self->dbconnect_noauto($myconfig);
3375 qq|SELECT customernumberinit FROM business
3376 WHERE id = ? FOR UPDATE|;
3377 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3379 return undef unless $var;
3381 if ($var =~ m/\d+$/) {
3382 my $new_var = (substr $var, $-[0]) * 1 + 1;
3383 my $len_diff = length($var) - $-[0] - length($new_var);
3384 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3390 $query = qq|UPDATE business
3391 SET customernumberinit = ?
3393 do_query($self, $dbh, $query, $var, $business_id);
3395 if (!$provided_dbh) {
3400 $main::lxdebug->leave_sub();
3405 sub get_partsgroup {
3406 $main::lxdebug->enter_sub();
3408 my ($self, $myconfig, $p) = @_;
3409 my $target = $p->{target} || 'all_partsgroup';
3411 my $dbh = $self->get_standard_dbh($myconfig);
3413 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3415 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3418 if ($p->{searchitems} eq 'part') {
3419 $query .= qq|WHERE p.inventory_accno_id > 0|;
3421 if ($p->{searchitems} eq 'service') {
3422 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3424 if ($p->{searchitems} eq 'assembly') {
3425 $query .= qq|WHERE p.assembly = '1'|;
3427 if ($p->{searchitems} eq 'labor') {
3428 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3431 $query .= qq|ORDER BY partsgroup|;
3434 $query = qq|SELECT id, partsgroup FROM partsgroup
3435 ORDER BY partsgroup|;
3438 if ($p->{language_code}) {
3439 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3440 t.description AS translation
3442 JOIN parts p ON (p.partsgroup_id = pg.id)
3443 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3444 ORDER BY translation|;
3445 @values = ($p->{language_code});
3448 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3450 $main::lxdebug->leave_sub();
3453 sub get_pricegroup {
3454 $main::lxdebug->enter_sub();
3456 my ($self, $myconfig, $p) = @_;
3458 my $dbh = $self->get_standard_dbh($myconfig);
3460 my $query = qq|SELECT p.id, p.pricegroup
3463 $query .= qq| ORDER BY pricegroup|;
3466 $query = qq|SELECT id, pricegroup FROM pricegroup
3467 ORDER BY pricegroup|;
3470 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3472 $main::lxdebug->leave_sub();
3476 # usage $form->all_years($myconfig, [$dbh])
3477 # return list of all years where bookings found
3480 $main::lxdebug->enter_sub();
3482 my ($self, $myconfig, $dbh) = @_;
3484 $dbh ||= $self->get_standard_dbh($myconfig);
3487 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3488 (SELECT MAX(transdate) FROM acc_trans)|;
3489 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3491 if ($myconfig->{dateformat} =~ /^yy/) {
3492 ($startdate) = split /\W/, $startdate;
3493 ($enddate) = split /\W/, $enddate;
3495 (@_) = split /\W/, $startdate;
3497 (@_) = split /\W/, $enddate;
3502 $startdate = substr($startdate,0,4);
3503 $enddate = substr($enddate,0,4);
3505 while ($enddate >= $startdate) {
3506 push @all_years, $enddate--;
3511 $main::lxdebug->leave_sub();
3515 $main::lxdebug->enter_sub();
3519 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3521 $main::lxdebug->leave_sub();
3525 $main::lxdebug->enter_sub();
3530 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3532 $main::lxdebug->leave_sub();
3535 sub prepare_for_printing {
3538 $self->{templates} ||= $::myconfig{templates};
3539 $self->{formname} ||= $self->{type};
3540 $self->{media} ||= 'email';
3542 die "'media' other than 'email', 'file', 'printer' is not supported yet" unless $self->{media} =~ m/^(?:email|file|printer)$/;
3544 # set shipto from billto unless set
3545 my $has_shipto = any { $self->{"shipto$_"} } qw(name street zipcode city country contact);
3546 if (!$has_shipto && ($self->{type} =~ m/^(?:purchase_order|request_quotation)$/)) {
3547 $self->{shiptoname} = $::myconfig{company};
3548 $self->{shiptostreet} = $::myconfig{address};
3551 my $language = $self->{language} ? '_' . $self->{language} : '';
3553 my ($language_tc, $output_numberformat, $output_dateformat, $output_longdates);
3554 if ($self->{language_id}) {
3555 ($language_tc, $output_numberformat, $output_dateformat, $output_longdates) = AM->get_language_details(\%::myconfig, $self, $self->{language_id});
3557 $output_dateformat = $::myconfig{dateformat};
3558 $output_numberformat = $::myconfig{numberformat};
3559 $output_longdates = 1;
3562 # Retrieve accounts for tax calculation.
3563 IC->retrieve_accounts(\%::myconfig, $self, map { $_ => $self->{"id_$_"} } 1 .. $self->{rowcount});
3565 if ($self->{type} =~ /_delivery_order$/) {
3566 DO->order_details();
3567 } elsif ($self->{type} =~ /sales_order|sales_quotation|request_quotation|purchase_order/) {
3568 OE->order_details(\%::myconfig, $self);
3570 IS->invoice_details(\%::myconfig, $self, $::locale);
3573 # Chose extension & set source file name
3574 my $extension = 'html';
3575 if ($self->{format} eq 'postscript') {
3576 $self->{postscript} = 1;
3578 } elsif ($self->{"format"} =~ /pdf/) {
3580 $extension = $self->{'format'} =~ m/opendocument/i ? 'odt' : 'tex';
3581 } elsif ($self->{"format"} =~ /opendocument/) {
3582 $self->{opendocument} = 1;
3584 } elsif ($self->{"format"} =~ /excel/) {
3589 my $printer_code = '_' . $self->{printer_code} if $self->{printer_code};
3590 my $email_extension = '_email' if -f "$self->{templates}/$self->{formname}_email${language}${printer_code}.${extension}";
3591 $self->{IN} = "$self->{formname}${email_extension}${language}${printer_code}.${extension}";
3594 $self->format_dates($output_dateformat, $output_longdates,
3595 qw(invdate orddate quodate pldate duedate reqdate transdate shippingdate deliverydate validitydate paymentdate datepaid
3596 transdate_oe deliverydate_oe employee_startdate employee_enddate),
3597 grep({ /^(?:datepaid|transdate_oe|reqdate|deliverydate|deliverydate_oe|transdate)_\d+$/ } keys(%{$self})));
3599 $self->reformat_numbers($output_numberformat, 2,
3600 qw(invtotal ordtotal quototal subtotal linetotal listprice sellprice netprice discount tax taxbase total paid),
3601 grep({ /^(?:linetotal|listprice|sellprice|netprice|taxbase|discount|paid|subtotal|total|tax)_\d+$/ } keys(%{$self})));
3603 $self->reformat_numbers($output_numberformat, undef, qw(qty price_factor), grep({ /^qty_\d+$/} keys(%{$self})));
3605 my ($cvar_date_fields, $cvar_number_fields) = CVar->get_field_format_list('module' => 'CT', 'prefix' => 'vc_');
3607 if (scalar @{ $cvar_date_fields }) {
3608 $self->format_dates($output_dateformat, $output_longdates, @{ $cvar_date_fields });
3611 while (my ($precision, $field_list) = each %{ $cvar_number_fields }) {
3612 $self->reformat_numbers($output_numberformat, $precision, @{ $field_list });
3619 my ($self, $dateformat, $longformat, @indices) = @_;
3621 $dateformat ||= $::myconfig{dateformat};
3623 foreach my $idx (@indices) {
3624 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3625 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3626 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $dateformat, $longformat);
3630 next unless defined $self->{$idx};
3632 if (!ref($self->{$idx})) {
3633 $self->{$idx} = $::locale->reformat_date(\%::myconfig, $self->{$idx}, $dateformat, $longformat);
3635 } elsif (ref($self->{$idx}) eq "ARRAY") {
3636 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3637 $self->{$idx}->[$i] = $::locale->reformat_date(\%::myconfig, $self->{$idx}->[$i], $dateformat, $longformat);
3643 sub reformat_numbers {
3644 my ($self, $numberformat, $places, @indices) = @_;
3646 return if !$numberformat || ($numberformat eq $::myconfig{numberformat});
3648 foreach my $idx (@indices) {
3649 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3650 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3651 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i]);
3655 next unless defined $self->{$idx};
3657 if (!ref($self->{$idx})) {
3658 $self->{$idx} = $self->parse_amount(\%::myconfig, $self->{$idx});
3660 } elsif (ref($self->{$idx}) eq "ARRAY") {
3661 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3662 $self->{$idx}->[$i] = $self->parse_amount(\%::myconfig, $self->{$idx}->[$i]);
3667 my $saved_numberformat = $::myconfig{numberformat};
3668 $::myconfig{numberformat} = $numberformat;
3670 foreach my $idx (@indices) {
3671 if ($self->{TEMPLATE_ARRAYS} && (ref($self->{TEMPLATE_ARRAYS}->{$idx}) eq "ARRAY")) {
3672 for (my $i = 0; $i < scalar(@{ $self->{TEMPLATE_ARRAYS}->{$idx} }); $i++) {
3673 $self->{TEMPLATE_ARRAYS}->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{TEMPLATE_ARRAYS}->{$idx}->[$i], $places);
3677 next unless defined $self->{$idx};
3679 if (!ref($self->{$idx})) {
3680 $self->{$idx} = $self->format_amount(\%::myconfig, $self->{$idx}, $places);
3682 } elsif (ref($self->{$idx}) eq "ARRAY") {
3683 for (my $i = 0; $i < scalar(@{ $self->{$idx} }); $i++) {
3684 $self->{$idx}->[$i] = $self->format_amount(\%::myconfig, $self->{$idx}->[$i], $places);
3689 $::myconfig{numberformat} = $saved_numberformat;
3698 SL::Form.pm - main data object.
3702 This is the main data object of Lx-Office.
3703 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3704 Points of interest for a beginner are:
3706 - $form->error - renders a generic error in html. accepts an error message
3707 - $form->get_standard_dbh - returns a database connection for the
3709 =head1 SPECIAL FUNCTIONS
3711 =head2 C<_store_value()>
3713 parses a complex var name, and stores it in the form.
3716 $form->_store_value($key, $value);
3718 keys must start with a string, and can contain various tokens.
3719 supported key structures are:
3722 simple key strings work as expected
3727 separating two keys by a dot (.) will result in a hash lookup for the inner value
3728 this is similar to the behaviour of java and templating mechanisms.
3730 filter.description => $form->{filter}->{description}
3732 3. array+hashref access
3734 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3735 using [+] instead of [] will force a new array index. this is useful for recurring
3736 data structures like part lists. put a [+] into the first varname, and use [] on the
3739 repeating these names in your template:
3742 invoice.items[].parts_id
3746 $form->{invoice}->{items}->[
3760 using brackets at the end of a name will result in a pure array to be created.
3761 note that you mustn't use [+], which is reserved for array+hash access and will
3762 result in undefined behaviour in array context.
3764 filter.status[] => $form->{status}->[ val1, val2, ... ]
3766 =head2 C<update_business> PARAMS
3769 \%config, - config hashref
3770 $business_id, - business id
3771 $dbh - optional database handle
3773 handles business (thats customer/vendor types) sequences.
3775 special behaviour for empty strings in customerinitnumber field:
3776 will in this case not increase the value, and return undef.
3778 =head2 C<redirect_header> $url
3780 Generates a HTTP redirection header for the new C<$url>. Constructs an
3781 absolute URL including scheme, host name and port. If C<$url> is a
3782 relative URL then it is considered relative to Lx-Office base URL.
3784 This function C<die>s if headers have already been created with
3785 C<$::form-E<gt>header>.
3789 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3790 print $::form->redirect_header('http://www.lx-office.org/');
3794 Generates a general purpose http/html header and includes most of the scripts
3795 ans stylesheets needed.
3797 Only one header will be generated. If the method was already called in this
3798 request it will not output anything and return undef. Also if no
3799 HTTP_USER_AGENT is found, no header is generated.
3801 Although header does not accept parameters itself, it will honor special
3802 hashkeys of its Form instance:
3810 If one of these is set, a http-equiv refresh is generated. Missing parameters
3811 default to 3 seconds and the refering url.
3817 If these are arrayrefs the contents will be inlined into the header.
3821 If true, a css snippet will be generated that sets the page in landscape mode.
3825 Used to override the default favicon.
3829 A html page title will be generated from this