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 #======================================================================
61 use List::Util qw(first max min sum);
62 use List::MoreUtils qw(any apply);
69 disconnect_standard_dbh();
72 sub disconnect_standard_dbh {
73 return unless $standard_dbh;
74 $standard_dbh->disconnect();
79 $main::lxdebug->enter_sub(2);
85 my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key;
90 $curr = \ $self->{ shift @tokens };
94 my $sep = shift @tokens;
95 my $key = shift @tokens;
97 $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]';
98 $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].';
99 $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].';
100 $curr = \ $$curr->{$key}
105 $main::lxdebug->leave_sub(2);
111 $main::lxdebug->enter_sub(2);
116 my @pairs = split(/&/, $input);
119 my ($key, $value) = split(/=/, $_, 2);
120 $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key);
123 $main::lxdebug->leave_sub(2);
126 sub _request_to_hash {
127 $main::lxdebug->enter_sub(2);
132 if (!$ENV{'CONTENT_TYPE'}
133 || ($ENV{'CONTENT_TYPE'} !~ /multipart\/form-data\s*;\s*boundary\s*=\s*(.+)$/)) {
135 $self->_input_to_hash($input);
137 $main::lxdebug->leave_sub(2);
141 my ($name, $filename, $headers_done, $content_type, $boundary_found, $need_cr, $previous);
143 my $boundary = '--' . $1;
145 foreach my $line (split m/\n/, $input) {
146 last if (($line eq "${boundary}--") || ($line eq "${boundary}--\r"));
148 if (($line eq $boundary) || ($line eq "$boundary\r")) {
149 ${ $previous } =~ s|\r?\n$|| if $previous;
155 $content_type = "text/plain";
162 next unless $boundary_found;
164 if (!$headers_done) {
165 $line =~ s/[\r\n]*$//;
172 if ($line =~ m|^content-disposition\s*:.*?form-data\s*;|i) {
173 if ($line =~ m|filename\s*=\s*"(.*?)"|i) {
175 substr $line, $-[0], $+[0] - $-[0], "";
178 if ($line =~ m|name\s*=\s*"(.*?)"|i) {
180 substr $line, $-[0], $+[0] - $-[0], "";
183 $previous = $self->_store_value($name, '') if ($name);
184 $self->{FILENAME} = $filename if ($filename);
189 if ($line =~ m|^content-type\s*:\s*(.*?)$|i) {
196 next unless $previous;
198 ${ $previous } .= "${line}\n";
201 ${ $previous } =~ s|\r?\n$|| if $previous;
203 $main::lxdebug->leave_sub(2);
206 sub _recode_recursively {
207 $main::lxdebug->enter_sub();
208 my ($iconv, $param) = @_;
210 if (any { ref $param eq $_ } qw(Form HASH)) {
211 foreach my $key (keys %{ $param }) {
212 if (!ref $param->{$key}) {
213 # Workaround for a bug: converting $param->{$key} directly
214 # leads to 'undef'. I don't know why. Converting a copy works,
216 $param->{$key} = $iconv->convert("" . $param->{$key});
218 _recode_recursively($iconv, $param->{$key});
222 } elsif (ref $param eq 'ARRAY') {
223 foreach my $idx (0 .. scalar(@{ $param }) - 1) {
224 if (!ref $param->[$idx]) {
225 # Workaround for a bug: converting $param->[$idx] directly
226 # leads to 'undef'. I don't know why. Converting a copy works,
228 $param->[$idx] = $iconv->convert("" . $param->[$idx]);
230 _recode_recursively($iconv, $param->[$idx]);
234 $main::lxdebug->leave_sub();
238 $main::lxdebug->enter_sub();
244 if ($LXDebug::watch_form) {
245 require SL::Watchdog;
246 tie %{ $self }, 'SL::Watchdog';
251 $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING};
252 $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0];
254 if ($ENV{CONTENT_LENGTH}) {
256 read STDIN, $content, $ENV{CONTENT_LENGTH};
257 $self->_request_to_hash($content);
260 my $db_charset = $main::dbcharset;
261 $db_charset ||= Common::DEFAULT_CHARSET;
263 my $encoding = $self->{INPUT_ENCODING} || $db_charset;
264 delete $self->{INPUT_ENCODING};
266 _recode_recursively(SL::Iconv->new($encoding, $db_charset), $self);
268 #$self->{version} = "2.6.1"; # Old hardcoded but secure style
269 open VERSION_FILE, "VERSION"; # New but flexible code reads version from VERSION-file
270 $self->{version} = <VERSION_FILE>;
272 $self->{version} =~ s/[^0-9A-Za-z\.\_\-]//g; # only allow numbers, letters, points, underscores and dashes. Prevents injecting of malicious code.
274 $main::lxdebug->leave_sub();
279 sub _flatten_variables_rec {
280 $main::lxdebug->enter_sub(2);
289 if ('' eq ref $curr->{$key}) {
290 @result = ({ 'key' => $prefix . $key, 'value' => $curr->{$key} });
292 } elsif ('HASH' eq ref $curr->{$key}) {
293 foreach my $hash_key (sort keys %{ $curr->{$key} }) {
294 push @result, $self->_flatten_variables_rec($curr->{$key}, $prefix . $key . '.', $hash_key);
298 foreach my $idx (0 .. scalar @{ $curr->{$key} } - 1) {
299 my $first_array_entry = 1;
301 foreach my $hash_key (sort keys %{ $curr->{$key}->[$idx] }) {
302 push @result, $self->_flatten_variables_rec($curr->{$key}->[$idx], $prefix . $key . ($first_array_entry ? '[+].' : '[].'), $hash_key);
303 $first_array_entry = 0;
308 $main::lxdebug->leave_sub(2);
313 sub flatten_variables {
314 $main::lxdebug->enter_sub(2);
322 push @variables, $self->_flatten_variables_rec($self, '', $_);
325 $main::lxdebug->leave_sub(2);
330 sub flatten_standard_variables {
331 $main::lxdebug->enter_sub(2);
334 my %skip_keys = map { $_ => 1 } (qw(login password header stylesheet titlebar version), @_);
338 foreach (grep { ! $skip_keys{$_} } keys %{ $self }) {
339 push @variables, $self->_flatten_variables_rec($self, '', $_);
342 $main::lxdebug->leave_sub(2);
348 $main::lxdebug->enter_sub();
354 map { print "$_ = $self->{$_}\n" } (sort keys %{$self});
356 $main::lxdebug->leave_sub();
360 $main::lxdebug->enter_sub(2);
363 my $password = $self->{password};
365 $self->{password} = 'X' x 8;
367 local $Data::Dumper::Sortkeys = 1;
368 my $output = Dumper($self);
370 $self->{password} = $password;
372 $main::lxdebug->leave_sub(2);
378 $main::lxdebug->enter_sub(2);
380 my ($self, $str) = @_;
382 $str = Encode::encode('utf-8-strict', $str) if $::locale->is_utf8;
383 $str =~ s/([^a-zA-Z0-9_.-])/sprintf("%%%02x", ord($1))/ge;
385 $main::lxdebug->leave_sub(2);
391 $main::lxdebug->enter_sub(2);
393 my ($self, $str) = @_;
398 $str =~ s/%([0-9a-fA-Z]{2})/pack("c",hex($1))/eg;
400 $main::lxdebug->leave_sub(2);
406 $main::lxdebug->enter_sub();
407 my ($self, $str) = @_;
409 if ($str && !ref($str)) {
410 $str =~ s/\"/"/g;
413 $main::lxdebug->leave_sub();
419 $main::lxdebug->enter_sub();
420 my ($self, $str) = @_;
422 if ($str && !ref($str)) {
423 $str =~ s/"/\"/g;
426 $main::lxdebug->leave_sub();
432 $main::lxdebug->enter_sub();
436 map({ print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } @_);
438 for (sort keys %$self) {
439 next if (($_ eq "header") || (ref($self->{$_}) ne ""));
440 print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n");
443 $main::lxdebug->leave_sub();
447 $main::lxdebug->enter_sub();
449 $main::lxdebug->show_backtrace();
451 my ($self, $msg) = @_;
452 if ($ENV{HTTP_USER_AGENT}) {
454 $self->show_generic_error($msg);
457 print STDERR "Error: $msg\n";
461 $main::lxdebug->leave_sub();
465 $main::lxdebug->enter_sub();
467 my ($self, $msg) = @_;
469 if ($ENV{HTTP_USER_AGENT}) {
472 if (!$self->{header}) {
478 <p class="message_ok"><b>$msg</b></p>
480 <script type="text/javascript">
482 // If JavaScript is enabled, the whole thing will be reloaded.
483 // The reason is: When one changes his menu setup (HTML / XUL / CSS ...)
484 // it now loads the correct code into the browser instead of do nothing.
485 setTimeout("top.frames.location.href='login.pl'",500);
494 if ($self->{info_function}) {
495 &{ $self->{info_function} }($msg);
501 $main::lxdebug->leave_sub();
504 # calculates the number of rows in a textarea based on the content and column number
505 # can be capped with maxrows
507 $main::lxdebug->enter_sub();
508 my ($self, $str, $cols, $maxrows, $minrows) = @_;
512 my $rows = sum map { int((length() - 2) / $cols) + 1 } split /\r/, $str;
515 $main::lxdebug->leave_sub();
517 return max(min($rows, $maxrows), $minrows);
521 $main::lxdebug->enter_sub();
523 my ($self, $msg) = @_;
525 $self->error("$msg\n" . $DBI::errstr);
527 $main::lxdebug->leave_sub();
531 $main::lxdebug->enter_sub();
533 my ($self, $name, $msg) = @_;
536 foreach my $part (split m/\./, $name) {
537 if (!$curr->{$part} || ($curr->{$part} =~ /^\s*$/)) {
540 $curr = $curr->{$part};
543 $main::lxdebug->leave_sub();
546 sub _get_request_uri {
549 return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR};
551 my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http';
552 my $port = $ENV{SERVER_PORT} || '';
553 $port = undef if (($scheme eq 'http' ) && ($port == 80))
554 || (($scheme eq 'https') && ($port == 443));
556 my $uri = URI->new("${scheme}://");
557 $uri->scheme($scheme);
559 $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR});
560 $uri->path_query($ENV{REQUEST_URI});
566 sub _add_to_request_uri {
569 my $relative_new_path = shift;
570 my $request_uri = shift || $self->_get_request_uri;
571 my $relative_new_uri = URI->new($relative_new_path);
572 my @request_segments = $request_uri->path_segments;
574 my $new_uri = $request_uri->clone;
575 $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments);
580 sub create_http_response {
581 $main::lxdebug->enter_sub();
586 my $cgi = $main::cgi;
587 $cgi ||= CGI->new('');
590 if (defined $main::auth) {
591 my $uri = $self->_get_request_uri;
592 my @segments = $uri->path_segments;
594 $uri->path_segments(@segments);
596 my $session_cookie_value = $main::auth->get_session_id();
598 if ($session_cookie_value) {
599 $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(),
600 '-value' => $session_cookie_value,
601 '-path' => $uri->path,
602 '-secure' => $ENV{HTTPS});
606 my %cgi_params = ('-type' => $params{content_type});
607 $cgi_params{'-charset'} = $params{charset} if ($params{charset});
608 $cgi_params{'-cookie'} = $session_cookie if ($session_cookie);
610 my $output = $cgi->header(%cgi_params);
612 $main::lxdebug->leave_sub();
619 $::lxdebug->enter_sub;
621 # extra code is currently only used by menuv3 and menuv4 to set their css.
622 # it is strongly deprecated, and will be changed in a future version.
623 my ($self, $extra_code) = @_;
624 my $db_charset = $::dbcharset || Common::DEFAULT_CHARSET;
627 $::lxdebug->leave_sub and return if !$ENV{HTTP_USER_AGENT} || $self->{header}++;
629 $self->{favicon} ||= "favicon.ico";
630 $self->{titlebar} = "$self->{title} - $self->{titlebar}" if $self->{title};
633 if ($self->{refresh_url} || $self->{refresh_time}) {
634 my $refresh_time = $self->{refresh_time} || 3;
635 my $refresh_url = $self->{refresh_url} || $ENV{REFERER};
636 push @header, "<meta http-equiv='refresh' content='$refresh_time;$refresh_url'>";
639 push @header, "<link rel='stylesheet' href='css/$_' type='text/css' title='Lx-Office stylesheet'>"
640 for grep { -f "css/$_" } apply { s|.*/|| } $self->{stylesheet}, $self->{stylesheets};
642 push @header, "<style type='text/css'>\@page { size:landscape; }</style>" if $self->{landscape};
643 push @header, "<link rel='shortcut icon' href='$self->{favicon}' type='image/x-icon'>" if -f $self->{favicon};
644 push @header, '<script type="text/javascript" src="js/jquery.js"></script>',
645 '<script type="text/javascript" src="js/common.js"></script>',
646 '<style type="text/css">@import url(js/jscalendar/calendar-win2k-1.css);</style>',
647 '<script type="text/javascript" src="js/jscalendar/calendar.js"></script>',
648 '<script type="text/javascript" src="js/jscalendar/lang/calendar-de.js"></script>',
649 '<script type="text/javascript" src="js/jscalendar/calendar-setup.js"></script>',
650 '<script type="text/javascript" src="js/part_selection.js"></script>';
651 push @header, $self->{javascript} if $self->{javascript};
652 push @header, map { $_->show_javascript } @{ $self->{AJAX} || [] };
653 push @header, "<script type='text/javascript'>function fokus(){ document.$self->{fokus}.focus(); }</script>" if $self->{fokus};
654 push @header, sprintf "<script type='text/javascript'>top.document.title='%s';</script>",
655 join ' - ', grep $_, $self->{title}, $self->{login}, $::myconfig{dbname}, $self->{version} if $self->{title};
657 # if there is a title, we put some JavaScript in to the page, wich writes a
658 # meaningful title-tag for our frameset.
660 if ($self->{title}) {
662 <script type="text/javascript">
664 // Write a meaningful title-tag for our frameset.
665 top.document.title="| . $self->{"title"} . qq| - | . $self->{"login"} . qq| - | . $::myconfig{dbname} . qq| - V| . $self->{"version"} . qq|";
671 print $self->create_http_response(content_type => 'text/html', charset => $db_charset);
672 print "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01//EN' 'http://www.w3.org/TR/html4/strict.dtd'>\n"
673 if $ENV{'HTTP_USER_AGENT'} =~ m/MSIE\s+\d/; # Other browsers may choke on menu scripts with DOCTYPE.
677 <meta http-equiv="Content-Type" content="text/html; charset=$db_charset">
678 <title>$self->{titlebar}</title>
680 print " $_\n" for @header;
682 <link rel="stylesheet" href="css/jquery.autocomplete.css" type="text/css" />
683 <meta name="robots" content="noindex,nofollow" />
684 <link rel="stylesheet" type="text/css" href="css/tabcontent.css" />
685 <script type="text/javascript" src="js/tabcontent.js">
687 /***********************************************
688 * Tab Content script v2.2- © Dynamic Drive DHTML code library (www.dynamicdrive.com)
689 * This notice MUST stay intact for legal use
690 * Visit Dynamic Drive at http://www.dynamicdrive.com/ for full source code
691 ***********************************************/
700 $::lxdebug->leave_sub;
703 sub ajax_response_header {
704 $main::lxdebug->enter_sub();
708 my $db_charset = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
709 my $cgi = $main::cgi || CGI->new('');
710 my $output = $cgi->header('-charset' => $db_charset);
712 $main::lxdebug->leave_sub();
717 sub redirect_header {
721 my $base_uri = $self->_get_request_uri;
722 my $new_uri = URI->new_abs($new_url, $base_uri);
724 die "Headers already sent" if $::self->{header};
727 my $cgi = $main::cgi || CGI->new('');
728 return $cgi->redirect($new_uri);
731 sub set_standard_title {
732 $::lxdebug->enter_sub;
735 $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}";
736 $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name};
737 $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name};
739 $::lxdebug->leave_sub;
742 sub _prepare_html_template {
743 $main::lxdebug->enter_sub();
745 my ($self, $file, $additional_params) = @_;
748 if (!%::myconfig || !$::myconfig{"countrycode"}) {
749 $language = $main::language;
751 $language = $main::myconfig{"countrycode"};
753 $language = "de" unless ($language);
755 if (-f "templates/webpages/${file}.html") {
756 if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) {
757 my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" .
758 "Please re-run 'locales.pl' in 'locale/${language}'.";
759 print(qq|<pre>$info</pre>|);
763 $file = "templates/webpages/${file}.html";
766 my $info = "Web page template '${file}' not found.\n";
767 print qq|<pre>$info</pre>|;
771 if ($self->{"DEBUG"}) {
772 $additional_params->{"DEBUG"} = $self->{"DEBUG"};
775 if ($additional_params->{"DEBUG"}) {
776 $additional_params->{"DEBUG"} =
777 "<br><em>DEBUG INFORMATION:</em><pre>" . $additional_params->{"DEBUG"} . "</pre>";
780 if (%main::myconfig) {
781 $::myconfig{jsc_dateformat} = apply {
785 } $::myconfig{"dateformat"};
786 $additional_params->{"myconfig"} ||= \%::myconfig;
787 map { $additional_params->{"myconfig_${_}"} = $main::myconfig{$_}; } keys %::myconfig;
790 $additional_params->{"conf_dbcharset"} = $::dbcharset;
791 $additional_params->{"conf_webdav"} = $::webdav;
792 $additional_params->{"conf_lizenzen"} = $::lizenzen;
793 $additional_params->{"conf_latex_templates"} = $::latex;
794 $additional_params->{"conf_opendocument_templates"} = $::opendocument_templates;
795 $additional_params->{"conf_vertreter"} = $::vertreter;
796 $additional_params->{"conf_show_best_before"} = $::show_best_before;
797 $additional_params->{"conf_parts_image_css"} = $::parts_image_css;
798 $additional_params->{"conf_parts_listing_images"} = $::parts_listing_images;
799 $additional_params->{"conf_parts_show_image"} = $::parts_show_image;
801 if (%main::debug_options) {
802 map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options;
805 if ($main::auth && $main::auth->{RIGHTS} && $main::auth->{RIGHTS}->{$self->{login}}) {
806 while (my ($key, $value) = each %{ $main::auth->{RIGHTS}->{$self->{login}} }) {
807 $additional_params->{"AUTH_RIGHTS_" . uc($key)} = $value;
811 $main::lxdebug->leave_sub();
816 sub parse_html_template {
817 $main::lxdebug->enter_sub();
819 my ($self, $file, $additional_params) = @_;
821 $additional_params ||= { };
823 my $real_file = $self->_prepare_html_template($file, $additional_params);
824 my $template = $self->template || $self->init_template;
826 map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self };
829 $template->process($real_file, $additional_params, \$output) || die $template->error;
831 $main::lxdebug->leave_sub();
839 return if $self->template;
841 return $self->template(Template->new({
846 'PLUGIN_BASE' => 'SL::Template::Plugin',
847 'INCLUDE_PATH' => '.:templates/webpages',
848 'COMPILE_EXT' => '.tcc',
849 'COMPILE_DIR' => $::userspath . '/templates-cache',
855 $self->{template_object} = shift if @_;
856 return $self->{template_object};
859 sub show_generic_error {
860 $main::lxdebug->enter_sub();
862 my ($self, $error, %params) = @_;
865 'title_error' => $params{title},
866 'label_error' => $error,
869 if ($params{action}) {
872 map { delete($self->{$_}); } qw(action);
873 map { push @vars, { "name" => $_, "value" => $self->{$_} } if (!ref($self->{$_})); } keys %{ $self };
875 $add_params->{SHOW_BUTTON} = 1;
876 $add_params->{BUTTON_LABEL} = $params{label} || $params{action};
877 $add_params->{VARIABLES} = \@vars;
879 } elsif ($params{back_button}) {
880 $add_params->{SHOW_BACK_BUTTON} = 1;
883 $self->{title} = $params{title} if $params{title};
886 print $self->parse_html_template("generic/error", $add_params);
888 print STDERR "Error: $error\n";
890 $main::lxdebug->leave_sub();
895 sub show_generic_information {
896 $main::lxdebug->enter_sub();
898 my ($self, $text, $title) = @_;
901 'title_information' => $title,
902 'label_information' => $text,
905 $self->{title} = $title if ($title);
908 print $self->parse_html_template("generic/information", $add_params);
910 $main::lxdebug->leave_sub();
915 # write Trigger JavaScript-Code ($qty = quantity of Triggers)
916 # changed it to accept an arbitrary number of triggers - sschoeling
918 $main::lxdebug->enter_sub();
921 my $myconfig = shift;
924 # set dateform for jsscript
927 "dd.mm.yy" => "%d.%m.%Y",
928 "dd-mm-yy" => "%d-%m-%Y",
929 "dd/mm/yy" => "%d/%m/%Y",
930 "mm/dd/yy" => "%m/%d/%Y",
931 "mm-dd-yy" => "%m-%d-%Y",
932 "yyyy-mm-dd" => "%Y-%m-%d",
935 my $ifFormat = defined($dateformats{$myconfig->{"dateformat"}}) ?
936 $dateformats{$myconfig->{"dateformat"}} : "%d.%m.%Y";
943 inputField : "| . (shift) . qq|",
944 ifFormat :"$ifFormat",
945 align : "| . (shift) . qq|",
946 button : "| . (shift) . qq|"
952 <script type="text/javascript">
953 <!--| . join("", @triggers) . qq|//-->
957 $main::lxdebug->leave_sub();
960 } #end sub write_trigger
963 $main::lxdebug->enter_sub();
965 my ($self, $msg) = @_;
967 if (!$self->{callback}) {
973 # my ($script, $argv) = split(/\?/, $self->{callback}, 2);
974 # $script =~ s|.*/||;
975 # $script =~ s|[^a-zA-Z0-9_\.]||g;
976 # exec("perl", "$script", $argv);
978 print $::form->redirect_header($self->{callback});
980 $main::lxdebug->leave_sub();
983 # sort of columns removed - empty sub
985 $main::lxdebug->enter_sub();
987 my ($self, @columns) = @_;
989 $main::lxdebug->leave_sub();
995 $main::lxdebug->enter_sub(2);
997 my ($self, $myconfig, $amount, $places, $dash) = @_;
1003 # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13
1005 my $neg = ($amount =~ s/^-//);
1006 my $exp = ($amount =~ m/[e]/) ? 1 : 0;
1008 if (defined($places) && ($places ne '')) {
1014 my ($actual_places) = ($amount =~ /\.(\d+)/);
1015 $actual_places = length($actual_places);
1016 $places = $actual_places > $places ? $actual_places : $places;
1019 $amount = $self->round_amount($amount, $places);
1022 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
1023 my @p = split(/\./, $amount); # split amount at decimal point
1025 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
1028 $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne '');
1031 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
1032 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
1033 ($neg ? "-$amount" : "$amount" ) ;
1037 $main::lxdebug->leave_sub(2);
1041 sub format_amount_units {
1042 $main::lxdebug->enter_sub();
1047 my $myconfig = \%main::myconfig;
1048 my $amount = $params{amount} * 1;
1049 my $places = $params{places};
1050 my $part_unit_name = $params{part_unit};
1051 my $amount_unit_name = $params{amount_unit};
1052 my $conv_units = $params{conv_units};
1053 my $max_places = $params{max_places};
1055 if (!$part_unit_name) {
1056 $main::lxdebug->leave_sub();
1060 AM->retrieve_all_units();
1061 my $all_units = $main::all_units;
1063 if (('' eq ref $conv_units) && ($conv_units =~ /convertible/)) {
1064 $conv_units = AM->convertible_units($all_units, $part_unit_name, $conv_units eq 'convertible_not_smaller');
1067 if (!scalar @{ $conv_units }) {
1068 my $result = $self->format_amount($myconfig, $amount, $places, undef, $max_places) . " " . $part_unit_name;
1069 $main::lxdebug->leave_sub();
1073 my $part_unit = $all_units->{$part_unit_name};
1074 my $conv_unit = ($amount_unit_name && ($amount_unit_name ne $part_unit_name)) ? $all_units->{$amount_unit_name} : $part_unit;
1076 $amount *= $conv_unit->{factor};
1081 foreach my $unit (@$conv_units) {
1082 my $last = $unit->{name} eq $part_unit->{name};
1084 $num = int($amount / $unit->{factor});
1085 $amount -= $num * $unit->{factor};
1088 if ($last ? $amount : $num) {
1089 push @values, { "unit" => $unit->{name},
1090 "amount" => $last ? $amount / $unit->{factor} : $num,
1091 "places" => $last ? $places : 0 };
1098 push @values, { "unit" => $part_unit_name,
1103 my $result = join " ", map { $self->format_amount($myconfig, $_->{amount}, $_->{places}, undef, $max_places), $_->{unit} } @values;
1105 $main::lxdebug->leave_sub();
1111 $main::lxdebug->enter_sub(2);
1116 $input =~ s/(^|[^\#]) \# (\d+) /$1$_[$2 - 1]/gx;
1117 $input =~ s/(^|[^\#]) \#\{(\d+)\}/$1$_[$2 - 1]/gx;
1118 $input =~ s/\#\#/\#/g;
1120 $main::lxdebug->leave_sub(2);
1128 $main::lxdebug->enter_sub(2);
1130 my ($self, $myconfig, $amount) = @_;
1132 if ( ($myconfig->{numberformat} eq '1.000,00')
1133 || ($myconfig->{numberformat} eq '1000,00')) {
1138 if ($myconfig->{numberformat} eq "1'000.00") {
1144 $main::lxdebug->leave_sub(2);
1146 return ($amount * 1);
1150 $main::lxdebug->enter_sub(2);
1152 my ($self, $amount, $places) = @_;
1155 # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung )
1157 # Round amounts to eight places before rounding to the requested
1158 # number of places. This gets rid of errors due to internal floating
1159 # point representation.
1160 $amount = $self->round_amount($amount, 8) if $places < 8;
1161 $amount = $amount * (10**($places));
1162 $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places));
1164 $main::lxdebug->leave_sub(2);
1166 return $round_amount;
1170 sub parse_template {
1171 $main::lxdebug->enter_sub();
1173 my ($self, $myconfig, $userspath) = @_;
1178 $self->{"cwd"} = getcwd();
1179 $self->{"tmpdir"} = $self->{cwd} . "/${userspath}";
1184 if ($self->{"format"} =~ /(opendocument|oasis)/i) {
1185 $template_type = 'OpenDocument';
1186 $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt';
1188 } elsif ($self->{"format"} =~ /(postscript|pdf)/i) {
1189 $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"};
1190 $template_type = 'LaTeX';
1191 $ext_for_format = 'pdf';
1193 } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) {
1194 $template_type = 'HTML';
1195 $ext_for_format = 'html';
1197 } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) {
1198 $template_type = 'XML';
1199 $ext_for_format = 'xml';
1201 } elsif ( $self->{"format"} =~ /elster(?:winston|taxbird)/i ) {
1202 $template_type = 'XML';
1204 } elsif ( $self->{"format"} =~ /excel/i ) {
1205 $template_type = 'Excel';
1206 $ext_for_format = 'xls';
1208 } elsif ( defined $self->{'format'}) {
1209 $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}");
1211 } elsif ( $self->{'format'} eq '' ) {
1212 $self->error("No Outputformat given: $self->{'format'}");
1214 } else { #Catch the rest
1215 $self->error("Outputformat not defined: $self->{'format'}");
1218 my $template = SL::Template::create(type => $template_type,
1219 file_name => $self->{IN},
1221 myconfig => $myconfig,
1222 userspath => $userspath);
1224 # Copy the notes from the invoice/sales order etc. back to the variable "notes" because that is where most templates expect it to be.
1225 $self->{"notes"} = $self->{ $self->{"formname"} . "notes" };
1227 if (!$self->{employee_id}) {
1228 map { $self->{"employee_${_}"} = $myconfig->{$_}; } qw(email tel fax name signature company address businessnumber co_ustid taxnumber duns);
1231 map { $self->{"${_}"} = $myconfig->{$_}; } qw(co_ustid);
1233 $self->{copies} = 1 if (($self->{copies} *= 1) <= 0);
1235 # OUT is used for the media, screen, printer, email
1236 # for postscript we store a copy in a temporary file
1238 my $prepend_userspath;
1240 if (!$self->{tmpfile}) {
1241 $self->{tmpfile} = "${fileid}.$self->{IN}";
1242 $prepend_userspath = 1;
1245 $prepend_userspath = 1 if substr($self->{tmpfile}, 0, length $userspath) eq $userspath;
1247 $self->{tmpfile} =~ s|.*/||;
1248 $self->{tmpfile} =~ s/[^a-zA-Z0-9\._\ \-]//g;
1249 $self->{tmpfile} = "$userspath/$self->{tmpfile}" if $prepend_userspath;
1251 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1252 $out = $self->{OUT};
1253 $self->{OUT} = ">$self->{tmpfile}";
1259 open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!");
1260 $result = $template->parse(*OUT);
1265 $result = $template->parse(*STDOUT);
1270 $self->error("$self->{IN} : " . $template->get_error());
1273 if ($self->{media} eq 'file') {
1274 copy(join('/', $self->{cwd}, $userspath, $self->{tmpfile}), $out =~ m|^/| ? $out : join('/', $self->{cwd}, $out)) if $template->uses_temp_file;
1276 chdir("$self->{cwd}");
1278 $::lxdebug->leave_sub();
1283 if ($template->uses_temp_file() || $self->{media} eq 'email') {
1285 if ($self->{media} eq 'email') {
1287 my $mail = new Mailer;
1289 map { $mail->{$_} = $self->{$_} }
1290 qw(cc bcc subject message version format);
1291 $mail->{charset} = $main::dbcharset ? $main::dbcharset : Common::DEFAULT_CHARSET;
1292 $mail->{to} = $self->{EMAIL_RECIPIENT} ? $self->{EMAIL_RECIPIENT} : $self->{email};
1293 $mail->{from} = qq|"$myconfig->{name}" <$myconfig->{email}>|;
1294 $mail->{fileid} = "$fileid.";
1295 $myconfig->{signature} =~ s/\r//g;
1297 # if we send html or plain text inline
1298 if (($self->{format} eq 'html') && ($self->{sendmode} eq 'inline')) {
1299 $mail->{contenttype} = "text/html";
1301 $mail->{message} =~ s/\r//g;
1302 $mail->{message} =~ s/\n/<br>\n/g;
1303 $myconfig->{signature} =~ s/\n/<br>\n/g;
1304 $mail->{message} .= "<br>\n-- <br>\n$myconfig->{signature}\n<br>";
1306 open(IN, $self->{tmpfile})
1307 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1309 $mail->{message} .= $_;
1316 if (!$self->{"do_not_attach"}) {
1317 my $attachment_name = $self->{attachment_filename} || $self->{tmpfile};
1318 $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format);
1319 $mail->{attachments} = [{ "filename" => $self->{tmpfile},
1320 "name" => $attachment_name }];
1323 $mail->{message} =~ s/\r//g;
1324 $mail->{message} .= "\n-- \n$myconfig->{signature}";
1328 my $err = $mail->send();
1329 $self->error($self->cleanup . "$err") if ($err);
1333 $self->{OUT} = $out;
1335 my $numbytes = (-s $self->{tmpfile});
1336 open(IN, $self->{tmpfile})
1337 or $self->error($self->cleanup . "$self->{tmpfile} : $!");
1339 $self->{copies} = 1 unless $self->{media} eq 'printer';
1341 chdir("$self->{cwd}");
1342 #print(STDERR "Kopien $self->{copies}\n");
1343 #print(STDERR "OUT $self->{OUT}\n");
1344 for my $i (1 .. $self->{copies}) {
1346 open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!");
1347 print OUT while <IN>;
1352 $self->{attachment_filename} = ($self->{attachment_filename})
1353 ? $self->{attachment_filename}
1354 : $self->generate_attachment_filename();
1356 # launch application
1357 print qq|Content-Type: | . $template->get_mime_type() . qq|
1358 Content-Disposition: attachment; filename="$self->{attachment_filename}"
1359 Content-Length: $numbytes
1363 $::locale->with_raw_io(\*STDOUT, sub { print while <IN> });
1374 chdir("$self->{cwd}");
1375 $main::lxdebug->leave_sub();
1378 sub get_formname_translation {
1379 $main::lxdebug->enter_sub();
1380 my ($self, $formname) = @_;
1382 $formname ||= $self->{formname};
1384 my %formname_translations = (
1385 bin_list => $main::locale->text('Bin List'),
1386 credit_note => $main::locale->text('Credit Note'),
1387 invoice => $main::locale->text('Invoice'),
1388 pick_list => $main::locale->text('Pick List'),
1389 proforma => $main::locale->text('Proforma Invoice'),
1390 purchase_order => $main::locale->text('Purchase Order'),
1391 request_quotation => $main::locale->text('RFQ'),
1392 sales_order => $main::locale->text('Confirmation'),
1393 sales_quotation => $main::locale->text('Quotation'),
1394 storno_invoice => $main::locale->text('Storno Invoice'),
1395 sales_delivery_order => $main::locale->text('Delivery Order'),
1396 purchase_delivery_order => $main::locale->text('Delivery Order'),
1397 dunning => $main::locale->text('Dunning'),
1400 $main::lxdebug->leave_sub();
1401 return $formname_translations{$formname}
1404 sub get_number_prefix_for_type {
1405 $main::lxdebug->enter_sub();
1409 (first { $self->{type} eq $_ } qw(invoice credit_note)) ? 'inv'
1410 : ($self->{type} =~ /_quotation$/) ? 'quo'
1411 : ($self->{type} =~ /_delivery_order$/) ? 'do'
1414 $main::lxdebug->leave_sub();
1418 sub get_extension_for_format {
1419 $main::lxdebug->enter_sub();
1422 my $extension = $self->{format} =~ /pdf/i ? ".pdf"
1423 : $self->{format} =~ /postscript/i ? ".ps"
1424 : $self->{format} =~ /opendocument/i ? ".odt"
1425 : $self->{format} =~ /excel/i ? ".xls"
1426 : $self->{format} =~ /html/i ? ".html"
1429 $main::lxdebug->leave_sub();
1433 sub generate_attachment_filename {
1434 $main::lxdebug->enter_sub();
1437 my $attachment_filename = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1438 my $prefix = $self->get_number_prefix_for_type();
1440 if ($self->{preview} && (first { $self->{type} eq $_ } qw(invoice credit_note))) {
1441 $attachment_filename .= ' (' . $main::locale->text('Preview') . ')' . $self->get_extension_for_format();
1443 } elsif ($attachment_filename && $self->{"${prefix}number"}) {
1444 $attachment_filename .= "_" . $self->{"${prefix}number"} . $self->get_extension_for_format();
1447 $attachment_filename = "";
1450 $attachment_filename = $main::locale->quote_special_chars('filenames', $attachment_filename);
1451 $attachment_filename =~ s|[\s/\\]+|_|g;
1453 $main::lxdebug->leave_sub();
1454 return $attachment_filename;
1457 sub generate_email_subject {
1458 $main::lxdebug->enter_sub();
1461 my $subject = $main::locale->unquote_special_chars('HTML', $self->get_formname_translation());
1462 my $prefix = $self->get_number_prefix_for_type();
1464 if ($subject && $self->{"${prefix}number"}) {
1465 $subject .= " " . $self->{"${prefix}number"}
1468 $main::lxdebug->leave_sub();
1473 $main::lxdebug->enter_sub();
1477 chdir("$self->{tmpdir}");
1480 if (-f "$self->{tmpfile}.err") {
1481 open(FH, "$self->{tmpfile}.err");
1486 if ($self->{tmpfile} && ! $::keep_temp_files) {
1487 $self->{tmpfile} =~ s|.*/||g;
1489 $self->{tmpfile} =~ s/\.\w+$//g;
1490 my $tmpfile = $self->{tmpfile};
1491 unlink(<$tmpfile.*>);
1494 chdir("$self->{cwd}");
1496 $main::lxdebug->leave_sub();
1502 $main::lxdebug->enter_sub();
1504 my ($self, $date, $myconfig) = @_;
1507 if ($date && $date =~ /\D/) {
1509 if ($myconfig->{dateformat} =~ /^yy/) {
1510 ($yy, $mm, $dd) = split /\D/, $date;
1512 if ($myconfig->{dateformat} =~ /^mm/) {
1513 ($mm, $dd, $yy) = split /\D/, $date;
1515 if ($myconfig->{dateformat} =~ /^dd/) {
1516 ($dd, $mm, $yy) = split /\D/, $date;
1521 $yy = ($yy < 70) ? $yy + 2000 : $yy;
1522 $yy = ($yy >= 70 && $yy <= 99) ? $yy + 1900 : $yy;
1524 $dd = "0$dd" if ($dd < 10);
1525 $mm = "0$mm" if ($mm < 10);
1527 $date = "$yy$mm$dd";
1530 $main::lxdebug->leave_sub();
1535 # Database routines used throughout
1537 sub _dbconnect_options {
1539 my $options = { pg_enable_utf8 => $::locale->is_utf8,
1546 $main::lxdebug->enter_sub(2);
1548 my ($self, $myconfig) = @_;
1550 # connect to database
1551 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options)
1555 if ($myconfig->{dboptions}) {
1556 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1559 $main::lxdebug->leave_sub(2);
1564 sub dbconnect_noauto {
1565 $main::lxdebug->enter_sub();
1567 my ($self, $myconfig) = @_;
1569 # connect to database
1570 my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser}, $myconfig->{dbpasswd}, $self->_dbconnect_options(AutoCommit => 0))
1574 if ($myconfig->{dboptions}) {
1575 $dbh->do($myconfig->{dboptions}) || $self->dberror($myconfig->{dboptions});
1578 $main::lxdebug->leave_sub();
1583 sub get_standard_dbh {
1584 $main::lxdebug->enter_sub(2);
1587 my $myconfig = shift || \%::myconfig;
1589 if ($standard_dbh && !$standard_dbh->{Active}) {
1590 $main::lxdebug->message(LXDebug->INFO(), "get_standard_dbh: \$standard_dbh is defined but not Active anymore");
1591 undef $standard_dbh;
1594 $standard_dbh ||= SL::DB::create->dbh;
1596 $main::lxdebug->leave_sub(2);
1598 return $standard_dbh;
1602 $main::lxdebug->enter_sub();
1604 my ($self, $date, $myconfig) = @_;
1605 my $dbh = $self->dbconnect($myconfig);
1607 my $query = "SELECT 1 FROM defaults WHERE ? < closedto";
1608 my $sth = prepare_execute_query($self, $dbh, $query, $date);
1609 my ($closed) = $sth->fetchrow_array;
1611 $main::lxdebug->leave_sub();
1616 sub update_balance {
1617 $main::lxdebug->enter_sub();
1619 my ($self, $dbh, $table, $field, $where, $value, @values) = @_;
1621 # if we have a value, go do it
1624 # retrieve balance from table
1625 my $query = "SELECT $field FROM $table WHERE $where FOR UPDATE";
1626 my $sth = prepare_execute_query($self, $dbh, $query, @values);
1627 my ($balance) = $sth->fetchrow_array;
1633 $query = "UPDATE $table SET $field = $balance WHERE $where";
1634 do_query($self, $dbh, $query, @values);
1636 $main::lxdebug->leave_sub();
1639 sub update_exchangerate {
1640 $main::lxdebug->enter_sub();
1642 my ($self, $dbh, $curr, $transdate, $buy, $sell) = @_;
1644 # some sanity check for currency
1646 $main::lxdebug->leave_sub();
1649 $query = qq|SELECT curr FROM defaults|;
1651 my ($currency) = selectrow_query($self, $dbh, $query);
1652 my ($defaultcurrency) = split m/:/, $currency;
1655 if ($curr eq $defaultcurrency) {
1656 $main::lxdebug->leave_sub();
1660 $query = qq|SELECT e.curr FROM exchangerate e
1661 WHERE e.curr = ? AND e.transdate = ?
1663 my $sth = prepare_execute_query($self, $dbh, $query, $curr, $transdate);
1672 $buy = conv_i($buy, "NULL");
1673 $sell = conv_i($sell, "NULL");
1676 if ($buy != 0 && $sell != 0) {
1677 $set = "buy = $buy, sell = $sell";
1678 } elsif ($buy != 0) {
1679 $set = "buy = $buy";
1680 } elsif ($sell != 0) {
1681 $set = "sell = $sell";
1684 if ($sth->fetchrow_array) {
1685 $query = qq|UPDATE exchangerate
1691 $query = qq|INSERT INTO exchangerate (curr, buy, sell, transdate)
1692 VALUES (?, $buy, $sell, ?)|;
1695 do_query($self, $dbh, $query, $curr, $transdate);
1697 $main::lxdebug->leave_sub();
1700 sub save_exchangerate {
1701 $main::lxdebug->enter_sub();
1703 my ($self, $myconfig, $currency, $transdate, $rate, $fld) = @_;
1705 my $dbh = $self->dbconnect($myconfig);
1709 $buy = $rate if $fld eq 'buy';
1710 $sell = $rate if $fld eq 'sell';
1713 $self->update_exchangerate($dbh, $currency, $transdate, $buy, $sell);
1718 $main::lxdebug->leave_sub();
1721 sub get_exchangerate {
1722 $main::lxdebug->enter_sub();
1724 my ($self, $dbh, $curr, $transdate, $fld) = @_;
1727 unless ($transdate) {
1728 $main::lxdebug->leave_sub();
1732 $query = qq|SELECT curr FROM defaults|;
1734 my ($currency) = selectrow_query($self, $dbh, $query);
1735 my ($defaultcurrency) = split m/:/, $currency;
1737 if ($currency eq $defaultcurrency) {
1738 $main::lxdebug->leave_sub();
1742 $query = qq|SELECT e.$fld FROM exchangerate e
1743 WHERE e.curr = ? AND e.transdate = ?|;
1744 my ($exchangerate) = selectrow_query($self, $dbh, $query, $curr, $transdate);
1748 $main::lxdebug->leave_sub();
1750 return $exchangerate;
1753 sub check_exchangerate {
1754 $main::lxdebug->enter_sub();
1756 my ($self, $myconfig, $currency, $transdate, $fld) = @_;
1758 if ($fld !~/^buy|sell$/) {
1759 $self->error('Fatal: check_exchangerate called with invalid buy/sell argument');
1762 unless ($transdate) {
1763 $main::lxdebug->leave_sub();
1767 my ($defaultcurrency) = $self->get_default_currency($myconfig);
1769 if ($currency eq $defaultcurrency) {
1770 $main::lxdebug->leave_sub();
1774 my $dbh = $self->get_standard_dbh($myconfig);
1775 my $query = qq|SELECT e.$fld FROM exchangerate e
1776 WHERE e.curr = ? AND e.transdate = ?|;
1778 my ($exchangerate) = selectrow_query($self, $dbh, $query, $currency, $transdate);
1780 $main::lxdebug->leave_sub();
1782 return $exchangerate;
1785 sub get_all_currencies {
1786 $main::lxdebug->enter_sub();
1789 my $myconfig = shift || \%::myconfig;
1790 my $dbh = $self->get_standard_dbh($myconfig);
1792 my $query = qq|SELECT curr FROM defaults|;
1794 my ($curr) = selectrow_query($self, $dbh, $query);
1795 my @currencies = grep { $_ } map { s/\s//g; $_ } split m/:/, $curr;
1797 $main::lxdebug->leave_sub();
1802 sub get_default_currency {
1803 $main::lxdebug->enter_sub();
1805 my ($self, $myconfig) = @_;
1806 my @currencies = $self->get_all_currencies($myconfig);
1808 $main::lxdebug->leave_sub();
1810 return $currencies[0];
1813 sub set_payment_options {
1814 $main::lxdebug->enter_sub();
1816 my ($self, $myconfig, $transdate) = @_;
1818 return $main::lxdebug->leave_sub() unless ($self->{payment_id});
1820 my $dbh = $self->get_standard_dbh($myconfig);
1823 qq|SELECT p.terms_netto, p.terms_skonto, p.percent_skonto, p.description_long | .
1824 qq|FROM payment_terms p | .
1827 ($self->{terms_netto}, $self->{terms_skonto}, $self->{percent_skonto},
1828 $self->{payment_terms}) =
1829 selectrow_query($self, $dbh, $query, $self->{payment_id});
1831 if ($transdate eq "") {
1832 if ($self->{invdate}) {
1833 $transdate = $self->{invdate};
1835 $transdate = $self->{transdate};
1840 qq|SELECT ?::date + ?::integer AS netto_date, ?::date + ?::integer AS skonto_date | .
1841 qq|FROM payment_terms|;
1842 ($self->{netto_date}, $self->{skonto_date}) =
1843 selectrow_query($self, $dbh, $query, $transdate, $self->{terms_netto}, $transdate, $self->{terms_skonto});
1845 my ($invtotal, $total);
1846 my (%amounts, %formatted_amounts);
1848 if ($self->{type} =~ /_order$/) {
1849 $amounts{invtotal} = $self->{ordtotal};
1850 $amounts{total} = $self->{ordtotal};
1852 } elsif ($self->{type} =~ /_quotation$/) {
1853 $amounts{invtotal} = $self->{quototal};
1854 $amounts{total} = $self->{quototal};
1857 $amounts{invtotal} = $self->{invtotal};
1858 $amounts{total} = $self->{total};
1860 $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto};
1862 map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts;
1864 $amounts{skonto_amount} = $amounts{invtotal} * $self->{percent_skonto};
1865 $amounts{invtotal_wo_skonto} = $amounts{invtotal} * (1 - $self->{percent_skonto});
1866 $amounts{total_wo_skonto} = $amounts{total} * (1 - $self->{percent_skonto});
1868 foreach (keys %amounts) {
1869 $amounts{$_} = $self->round_amount($amounts{$_}, 2);
1870 $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}, 2);
1873 if ($self->{"language_id"}) {
1875 qq|SELECT t.description_long, l.output_numberformat, l.output_dateformat, l.output_longdates | .
1876 qq|FROM translation_payment_terms t | .
1877 qq|LEFT JOIN language l ON t.language_id = l.id | .
1878 qq|WHERE (t.language_id = ?) AND (t.payment_terms_id = ?)|;
1879 my ($description_long, $output_numberformat, $output_dateformat,
1880 $output_longdates) =
1881 selectrow_query($self, $dbh, $query,
1882 $self->{"language_id"}, $self->{"payment_id"});
1884 $self->{payment_terms} = $description_long if ($description_long);
1886 if ($output_dateformat) {
1887 foreach my $key (qw(netto_date skonto_date)) {
1889 $main::locale->reformat_date($myconfig, $self->{$key},
1895 if ($output_numberformat &&
1896 ($output_numberformat ne $myconfig->{"numberformat"})) {
1897 my $saved_numberformat = $myconfig->{"numberformat"};
1898 $myconfig->{"numberformat"} = $output_numberformat;
1899 map { $formatted_amounts{$_} = $self->format_amount($myconfig, $amounts{$_}) } keys %amounts;
1900 $myconfig->{"numberformat"} = $saved_numberformat;
1904 $self->{payment_terms} =~ s/<%netto_date%>/$self->{netto_date}/g;
1905 $self->{payment_terms} =~ s/<%skonto_date%>/$self->{skonto_date}/g;
1906 $self->{payment_terms} =~ s/<%currency%>/$self->{currency}/g;
1907 $self->{payment_terms} =~ s/<%terms_netto%>/$self->{terms_netto}/g;
1908 $self->{payment_terms} =~ s/<%account_number%>/$self->{account_number}/g;
1909 $self->{payment_terms} =~ s/<%bank%>/$self->{bank}/g;
1910 $self->{payment_terms} =~ s/<%bank_code%>/$self->{bank_code}/g;
1912 map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts;
1914 $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent};
1916 $main::lxdebug->leave_sub();
1920 sub get_template_language {
1921 $main::lxdebug->enter_sub();
1923 my ($self, $myconfig) = @_;
1925 my $template_code = "";
1927 if ($self->{language_id}) {
1928 my $dbh = $self->get_standard_dbh($myconfig);
1929 my $query = qq|SELECT template_code FROM language WHERE id = ?|;
1930 ($template_code) = selectrow_query($self, $dbh, $query, $self->{language_id});
1933 $main::lxdebug->leave_sub();
1935 return $template_code;
1938 sub get_printer_code {
1939 $main::lxdebug->enter_sub();
1941 my ($self, $myconfig) = @_;
1943 my $template_code = "";
1945 if ($self->{printer_id}) {
1946 my $dbh = $self->get_standard_dbh($myconfig);
1947 my $query = qq|SELECT template_code, printer_command FROM printers WHERE id = ?|;
1948 ($template_code, $self->{printer_command}) = selectrow_query($self, $dbh, $query, $self->{printer_id});
1951 $main::lxdebug->leave_sub();
1953 return $template_code;
1957 $main::lxdebug->enter_sub();
1959 my ($self, $myconfig) = @_;
1961 my $template_code = "";
1963 if ($self->{shipto_id}) {
1964 my $dbh = $self->get_standard_dbh($myconfig);
1965 my $query = qq|SELECT * FROM shipto WHERE shipto_id = ?|;
1966 my $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{shipto_id});
1967 map({ $self->{$_} = $ref->{$_} } keys(%$ref));
1970 $main::lxdebug->leave_sub();
1974 $main::lxdebug->enter_sub();
1976 my ($self, $dbh, $id, $module) = @_;
1981 foreach my $item (qw(name department_1 department_2 street zipcode city country
1982 contact cp_gender phone fax email)) {
1983 if ($self->{"shipto$item"}) {
1984 $shipto = 1 if ($self->{$item} ne $self->{"shipto$item"});
1986 push(@values, $self->{"shipto${item}"});
1990 if ($self->{shipto_id}) {
1991 my $query = qq|UPDATE shipto set
1993 shiptodepartment_1 = ?,
1994 shiptodepartment_2 = ?,
2000 shiptocp_gender = ?,
2004 WHERE shipto_id = ?|;
2005 do_query($self, $dbh, $query, @values, $self->{shipto_id});
2007 my $query = qq|SELECT * FROM shipto
2008 WHERE shiptoname = ? AND
2009 shiptodepartment_1 = ? AND
2010 shiptodepartment_2 = ? AND
2011 shiptostreet = ? AND
2012 shiptozipcode = ? AND
2014 shiptocountry = ? AND
2015 shiptocontact = ? AND
2016 shiptocp_gender = ? AND
2022 my $insert_check = selectfirst_hashref_query($self, $dbh, $query, @values, $module, $id);
2025 qq|INSERT INTO shipto (trans_id, shiptoname, shiptodepartment_1, shiptodepartment_2,
2026 shiptostreet, shiptozipcode, shiptocity, shiptocountry,
2027 shiptocontact, shiptocp_gender, shiptophone, shiptofax, shiptoemail, module)
2028 VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)|;
2029 do_query($self, $dbh, $query, $id, @values, $module);
2034 $main::lxdebug->leave_sub();
2038 $main::lxdebug->enter_sub();
2040 my ($self, $dbh) = @_;
2042 $dbh ||= $self->get_standard_dbh(\%main::myconfig);
2044 my $query = qq|SELECT id, name FROM employee WHERE login = ?|;
2045 ($self->{"employee_id"}, $self->{"employee"}) = selectrow_query($self, $dbh, $query, $self->{login});
2046 $self->{"employee_id"} *= 1;
2048 $main::lxdebug->leave_sub();
2051 sub get_employee_data {
2052 $main::lxdebug->enter_sub();
2057 Common::check_params(\%params, qw(prefix));
2058 Common::check_params_x(\%params, qw(id));
2061 $main::lxdebug->leave_sub();
2065 my $myconfig = \%main::myconfig;
2066 my $dbh = $params{dbh} || $self->get_standard_dbh($myconfig);
2068 my ($login) = selectrow_query($self, $dbh, qq|SELECT login FROM employee WHERE id = ?|, conv_i($params{id}));
2071 my $user = User->new($login);
2072 map { $self->{$params{prefix} . "_${_}"} = $user->{$_}; } qw(address businessnumber co_ustid company duns email fax name signature taxnumber tel);
2074 $self->{$params{prefix} . '_login'} = $login;
2075 $self->{$params{prefix} . '_name'} ||= $login;
2078 $main::lxdebug->leave_sub();
2082 $main::lxdebug->enter_sub();
2084 my ($self, $myconfig, $reference_date) = @_;
2086 $reference_date = $reference_date ? conv_dateq($reference_date) . '::DATE' : 'current_date';
2088 my $dbh = $self->get_standard_dbh($myconfig);
2089 my $query = qq|SELECT ${reference_date} + terms_netto FROM payment_terms WHERE id = ?|;
2090 my ($duedate) = selectrow_query($self, $dbh, $query, $self->{payment_id});
2092 $main::lxdebug->leave_sub();
2098 $main::lxdebug->enter_sub();
2100 my ($self, $dbh, $id, $key) = @_;
2102 $key = "all_contacts" unless ($key);
2106 $main::lxdebug->leave_sub();
2111 qq|SELECT cp_id, cp_cv_id, cp_name, cp_givenname, cp_abteilung | .
2112 qq|FROM contacts | .
2113 qq|WHERE cp_cv_id = ? | .
2114 qq|ORDER BY lower(cp_name)|;
2116 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $id);
2118 $main::lxdebug->leave_sub();
2122 $main::lxdebug->enter_sub();
2124 my ($self, $dbh, $key) = @_;
2126 my ($all, $old_id, $where, @values);
2128 if (ref($key) eq "HASH") {
2131 $key = "ALL_PROJECTS";
2133 foreach my $p (keys(%{$params})) {
2135 $all = $params->{$p};
2136 } elsif ($p eq "old_id") {
2137 $old_id = $params->{$p};
2138 } elsif ($p eq "key") {
2139 $key = $params->{$p};
2145 $where = "WHERE active ";
2147 if (ref($old_id) eq "ARRAY") {
2148 my @ids = grep({ $_ } @{$old_id});
2150 $where .= " OR id IN (" . join(",", map({ "?" } @ids)) . ") ";
2151 push(@values, @ids);
2154 $where .= " OR (id = ?) ";
2155 push(@values, $old_id);
2161 qq|SELECT id, projectnumber, description, active | .
2164 qq|ORDER BY lower(projectnumber)|;
2166 $self->{$key} = selectall_hashref_query($self, $dbh, $query, @values);
2168 $main::lxdebug->leave_sub();
2172 $main::lxdebug->enter_sub();
2174 my ($self, $dbh, $vc_id, $key) = @_;
2176 $key = "all_shipto" unless ($key);
2179 # get shipping addresses
2180 my $query = qq|SELECT * FROM shipto WHERE trans_id = ?|;
2182 $self->{$key} = selectall_hashref_query($self, $dbh, $query, $vc_id);
2188 $main::lxdebug->leave_sub();
2192 $main::lxdebug->enter_sub();
2194 my ($self, $dbh, $key) = @_;
2196 $key = "all_printers" unless ($key);
2198 my $query = qq|SELECT id, printer_description, printer_command, template_code FROM printers|;
2200 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2202 $main::lxdebug->leave_sub();
2206 $main::lxdebug->enter_sub();
2208 my ($self, $dbh, $params) = @_;
2211 $key = $params->{key};
2212 $key = "all_charts" unless ($key);
2214 my $transdate = quote_db_date($params->{transdate});
2217 qq|SELECT c.id, c.accno, c.description, c.link, c.charttype, tk.taxkey_id, tk.tax_id | .
2219 qq|LEFT JOIN taxkeys tk ON | .
2220 qq|(tk.id = (SELECT id FROM taxkeys | .
2221 qq| WHERE taxkeys.chart_id = c.id AND startdate <= $transdate | .
2222 qq| ORDER BY startdate DESC LIMIT 1)) | .
2223 qq|ORDER BY c.accno|;
2225 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2227 $main::lxdebug->leave_sub();
2230 sub _get_taxcharts {
2231 $main::lxdebug->enter_sub();
2233 my ($self, $dbh, $params) = @_;
2235 my $key = "all_taxcharts";
2238 if (ref $params eq 'HASH') {
2239 $key = $params->{key} if ($params->{key});
2240 if ($params->{module} eq 'AR') {
2241 push @where, 'taxkey NOT IN (8, 9, 18, 19)';
2243 } elsif ($params->{module} eq 'AP') {
2244 push @where, 'taxkey NOT IN (1, 2, 3, 12, 13)';
2251 my $where = ' WHERE ' . join(' AND ', map { "($_)" } @where) if (@where);
2253 my $query = qq|SELECT * FROM tax $where ORDER BY taxkey|;
2255 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2257 $main::lxdebug->leave_sub();
2261 $main::lxdebug->enter_sub();
2263 my ($self, $dbh, $key) = @_;
2265 $key = "all_taxzones" unless ($key);
2267 my $query = qq|SELECT * FROM tax_zones ORDER BY id|;
2269 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2271 $main::lxdebug->leave_sub();
2274 sub _get_employees {
2275 $main::lxdebug->enter_sub();
2277 my ($self, $dbh, $default_key, $key) = @_;
2279 $key = $default_key unless ($key);
2280 $self->{$key} = selectall_hashref_query($self, $dbh, qq|SELECT * FROM employee ORDER BY lower(name)|);
2282 $main::lxdebug->leave_sub();
2285 sub _get_business_types {
2286 $main::lxdebug->enter_sub();
2288 my ($self, $dbh, $key) = @_;
2290 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2291 $options->{key} ||= "all_business_types";
2294 if (exists $options->{salesman}) {
2295 $where = 'WHERE ' . ($options->{salesman} ? '' : 'NOT ') . 'COALESCE(salesman)';
2298 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, qq|SELECT * FROM business $where ORDER BY lower(description)|);
2300 $main::lxdebug->leave_sub();
2303 sub _get_languages {
2304 $main::lxdebug->enter_sub();
2306 my ($self, $dbh, $key) = @_;
2308 $key = "all_languages" unless ($key);
2310 my $query = qq|SELECT * FROM language ORDER BY id|;
2312 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2314 $main::lxdebug->leave_sub();
2317 sub _get_dunning_configs {
2318 $main::lxdebug->enter_sub();
2320 my ($self, $dbh, $key) = @_;
2322 $key = "all_dunning_configs" unless ($key);
2324 my $query = qq|SELECT * FROM dunning_config ORDER BY dunning_level|;
2326 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2328 $main::lxdebug->leave_sub();
2331 sub _get_currencies {
2332 $main::lxdebug->enter_sub();
2334 my ($self, $dbh, $key) = @_;
2336 $key = "all_currencies" unless ($key);
2338 my $query = qq|SELECT curr AS currency FROM defaults|;
2340 $self->{$key} = [split(/\:/ , selectfirst_hashref_query($self, $dbh, $query)->{currency})];
2342 $main::lxdebug->leave_sub();
2346 $main::lxdebug->enter_sub();
2348 my ($self, $dbh, $key) = @_;
2350 $key = "all_payments" unless ($key);
2352 my $query = qq|SELECT * FROM payment_terms ORDER BY id|;
2354 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2356 $main::lxdebug->leave_sub();
2359 sub _get_customers {
2360 $main::lxdebug->enter_sub();
2362 my ($self, $dbh, $key) = @_;
2364 my $options = ref $key eq 'HASH' ? $key : { key => $key };
2365 $options->{key} ||= "all_customers";
2366 my $limit_clause = "LIMIT $options->{limit}" if $options->{limit};
2369 push @where, qq|business_id IN (SELECT id FROM business WHERE salesman)| if $options->{business_is_salesman};
2370 push @where, qq|NOT obsolete| if !$options->{with_obsolete};
2371 my $where_str = @where ? "WHERE " . join(" AND ", map { "($_)" } @where) : '';
2373 my $query = qq|SELECT * FROM customer $where_str ORDER BY name $limit_clause|;
2374 $self->{ $options->{key} } = selectall_hashref_query($self, $dbh, $query);
2376 $main::lxdebug->leave_sub();
2380 $main::lxdebug->enter_sub();
2382 my ($self, $dbh, $key) = @_;
2384 $key = "all_vendors" unless ($key);
2386 my $query = qq|SELECT * FROM vendor WHERE NOT obsolete ORDER BY name|;
2388 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2390 $main::lxdebug->leave_sub();
2393 sub _get_departments {
2394 $main::lxdebug->enter_sub();
2396 my ($self, $dbh, $key) = @_;
2398 $key = "all_departments" unless ($key);
2400 my $query = qq|SELECT * FROM department ORDER BY description|;
2402 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2404 $main::lxdebug->leave_sub();
2407 sub _get_warehouses {
2408 $main::lxdebug->enter_sub();
2410 my ($self, $dbh, $param) = @_;
2412 my ($key, $bins_key);
2414 if ('' eq ref $param) {
2418 $key = $param->{key};
2419 $bins_key = $param->{bins};
2422 my $query = qq|SELECT w.* FROM warehouse w
2423 WHERE (NOT w.invalid) AND
2424 ((SELECT COUNT(b.*) FROM bin b WHERE b.warehouse_id = w.id) > 0)
2425 ORDER BY w.sortkey|;
2427 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2430 $query = qq|SELECT id, description FROM bin WHERE warehouse_id = ?|;
2431 my $sth = prepare_query($self, $dbh, $query);
2433 foreach my $warehouse (@{ $self->{$key} }) {
2434 do_statement($self, $sth, $query, $warehouse->{id});
2435 $warehouse->{$bins_key} = [];
2437 while (my $ref = $sth->fetchrow_hashref()) {
2438 push @{ $warehouse->{$bins_key} }, $ref;
2444 $main::lxdebug->leave_sub();
2448 $main::lxdebug->enter_sub();
2450 my ($self, $dbh, $table, $key, $sortkey) = @_;
2452 my $query = qq|SELECT * FROM $table|;
2453 $query .= qq| ORDER BY $sortkey| if ($sortkey);
2455 $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2457 $main::lxdebug->leave_sub();
2461 # $main::lxdebug->enter_sub();
2463 # my ($self, $dbh, $key) = @_;
2465 # $key ||= "all_groups";
2467 # my $groups = $main::auth->read_groups();
2469 # $self->{$key} = selectall_hashref_query($self, $dbh, $query);
2471 # $main::lxdebug->leave_sub();
2475 $main::lxdebug->enter_sub();
2480 my $dbh = $self->get_standard_dbh(\%main::myconfig);
2481 my ($sth, $query, $ref);
2483 my $vc = $self->{"vc"} eq "customer" ? "customer" : "vendor";
2484 my $vc_id = $self->{"${vc}_id"};
2486 if ($params{"contacts"}) {
2487 $self->_get_contacts($dbh, $vc_id, $params{"contacts"});
2490 if ($params{"shipto"}) {
2491 $self->_get_shipto($dbh, $vc_id, $params{"shipto"});
2494 if ($params{"projects"} || $params{"all_projects"}) {
2495 $self->_get_projects($dbh, $params{"all_projects"} ?
2496 $params{"all_projects"} : $params{"projects"},
2497 $params{"all_projects"} ? 1 : 0);
2500 if ($params{"printers"}) {
2501 $self->_get_printers($dbh, $params{"printers"});
2504 if ($params{"languages"}) {
2505 $self->_get_languages($dbh, $params{"languages"});
2508 if ($params{"charts"}) {
2509 $self->_get_charts($dbh, $params{"charts"});
2512 if ($params{"taxcharts"}) {
2513 $self->_get_taxcharts($dbh, $params{"taxcharts"});
2516 if ($params{"taxzones"}) {
2517 $self->_get_taxzones($dbh, $params{"taxzones"});
2520 if ($params{"employees"}) {
2521 $self->_get_employees($dbh, "all_employees", $params{"employees"});
2524 if ($params{"salesmen"}) {
2525 $self->_get_employees($dbh, "all_salesmen", $params{"salesmen"});
2528 if ($params{"business_types"}) {
2529 $self->_get_business_types($dbh, $params{"business_types"});
2532 if ($params{"dunning_configs"}) {
2533 $self->_get_dunning_configs($dbh, $params{"dunning_configs"});
2536 if($params{"currencies"}) {
2537 $self->_get_currencies($dbh, $params{"currencies"});
2540 if($params{"customers"}) {
2541 $self->_get_customers($dbh, $params{"customers"});
2544 if($params{"vendors"}) {
2545 if (ref $params{"vendors"} eq 'HASH') {
2546 $self->_get_vendors($dbh, $params{"vendors"}{key}, $params{"vendors"}{limit});
2548 $self->_get_vendors($dbh, $params{"vendors"});
2552 if($params{"payments"}) {
2553 $self->_get_payments($dbh, $params{"payments"});
2556 if($params{"departments"}) {
2557 $self->_get_departments($dbh, $params{"departments"});
2560 if ($params{price_factors}) {
2561 $self->_get_simple($dbh, 'price_factors', $params{price_factors}, 'sortkey');
2564 if ($params{warehouses}) {
2565 $self->_get_warehouses($dbh, $params{warehouses});
2568 # if ($params{groups}) {
2569 # $self->_get_groups($dbh, $params{groups});
2572 if ($params{partsgroup}) {
2573 $self->get_partsgroup(\%main::myconfig, { all => 1, target => $params{partsgroup} });
2576 $main::lxdebug->leave_sub();
2579 # this sub gets the id and name from $table
2581 $main::lxdebug->enter_sub();
2583 my ($self, $myconfig, $table) = @_;
2585 # connect to database
2586 my $dbh = $self->get_standard_dbh($myconfig);
2588 $table = $table eq "customer" ? "customer" : "vendor";
2589 my $arap = $self->{arap} eq "ar" ? "ar" : "ap";
2591 my ($query, @values);
2593 if (!$self->{openinvoices}) {
2595 if ($self->{customernumber} ne "") {
2596 $where = qq|(vc.customernumber ILIKE ?)|;
2597 push(@values, '%' . $self->{customernumber} . '%');
2599 $where = qq|(vc.name ILIKE ?)|;
2600 push(@values, '%' . $self->{$table} . '%');
2604 qq~SELECT vc.id, vc.name,
2605 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2607 WHERE $where AND (NOT vc.obsolete)
2611 qq~SELECT DISTINCT vc.id, vc.name,
2612 vc.street || ' ' || vc.zipcode || ' ' || vc.city || ' ' || vc.country AS address
2614 JOIN $table vc ON (a.${table}_id = vc.id)
2615 WHERE NOT (a.amount = a.paid) AND (vc.name ILIKE ?)
2617 push(@values, '%' . $self->{$table} . '%');
2620 $self->{name_list} = selectall_hashref_query($self, $dbh, $query, @values);
2622 $main::lxdebug->leave_sub();
2624 return scalar(@{ $self->{name_list} });
2627 # the selection sub is used in the AR, AP, IS, IR and OE module
2630 $main::lxdebug->enter_sub();
2632 my ($self, $myconfig, $table, $module) = @_;
2635 my $dbh = $self->get_standard_dbh;
2637 $table = $table eq "customer" ? "customer" : "vendor";
2639 my $query = qq|SELECT count(*) FROM $table|;
2640 my ($count) = selectrow_query($self, $dbh, $query);
2642 # build selection list
2643 if ($count <= $myconfig->{vclimit}) {
2644 $query = qq|SELECT id, name, salesman_id
2645 FROM $table WHERE NOT obsolete
2647 $self->{"all_$table"} = selectall_hashref_query($self, $dbh, $query);
2651 $self->get_employee($dbh);
2653 # setup sales contacts
2654 $query = qq|SELECT e.id, e.name
2656 WHERE (e.sales = '1') AND (NOT e.id = ?)|;
2657 $self->{all_employees} = selectall_hashref_query($self, $dbh, $query, $self->{employee_id});
2660 push(@{ $self->{all_employees} },
2661 { id => $self->{employee_id},
2662 name => $self->{employee} });
2664 # sort the whole thing
2665 @{ $self->{all_employees} } =
2666 sort { $a->{name} cmp $b->{name} } @{ $self->{all_employees} };
2668 if ($module eq 'AR') {
2670 # prepare query for departments
2671 $query = qq|SELECT id, description
2674 ORDER BY description|;
2677 $query = qq|SELECT id, description
2679 ORDER BY description|;
2682 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2685 $query = qq|SELECT id, description
2689 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2692 $query = qq|SELECT printer_description, id
2694 ORDER BY printer_description|;
2696 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2699 $query = qq|SELECT id, description
2703 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2705 $main::lxdebug->leave_sub();
2708 sub language_payment {
2709 $main::lxdebug->enter_sub();
2711 my ($self, $myconfig) = @_;
2713 my $dbh = $self->get_standard_dbh($myconfig);
2715 my $query = qq|SELECT id, description
2719 $self->{languages} = selectall_hashref_query($self, $dbh, $query);
2722 $query = qq|SELECT printer_description, id
2724 ORDER BY printer_description|;
2726 $self->{printers} = selectall_hashref_query($self, $dbh, $query);
2729 $query = qq|SELECT id, description
2733 $self->{payment_terms} = selectall_hashref_query($self, $dbh, $query);
2735 # get buchungsgruppen
2736 $query = qq|SELECT id, description
2737 FROM buchungsgruppen|;
2739 $self->{BUCHUNGSGRUPPEN} = selectall_hashref_query($self, $dbh, $query);
2741 $main::lxdebug->leave_sub();
2744 # this is only used for reports
2745 sub all_departments {
2746 $main::lxdebug->enter_sub();
2748 my ($self, $myconfig, $table) = @_;
2750 my $dbh = $self->get_standard_dbh($myconfig);
2753 if ($table eq 'customer') {
2754 $where = "WHERE role = 'P' ";
2757 my $query = qq|SELECT id, description
2760 ORDER BY description|;
2761 $self->{all_departments} = selectall_hashref_query($self, $dbh, $query);
2763 delete($self->{all_departments}) unless (@{ $self->{all_departments} || [] });
2765 $main::lxdebug->leave_sub();
2769 $main::lxdebug->enter_sub();
2771 my ($self, $module, $myconfig, $table, $provided_dbh) = @_;
2774 if ($table eq "customer") {
2783 $self->all_vc($myconfig, $table, $module);
2785 # get last customers or vendors
2786 my ($query, $sth, $ref);
2788 my $dbh = $provided_dbh ? $provided_dbh : $self->get_standard_dbh($myconfig);
2793 my $transdate = "current_date";
2794 if ($self->{transdate}) {
2795 $transdate = $dbh->quote($self->{transdate});
2798 # now get the account numbers
2799 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2800 FROM chart c, taxkeys tk
2801 WHERE (c.link LIKE ?) AND (c.id = tk.chart_id) AND tk.id =
2802 (SELECT id FROM taxkeys WHERE (taxkeys.chart_id = c.id) AND (startdate <= $transdate) ORDER BY startdate DESC LIMIT 1)
2805 $sth = $dbh->prepare($query);
2807 do_statement($self, $sth, $query, '%' . $module . '%');
2809 $self->{accounts} = "";
2810 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2812 foreach my $key (split(/:/, $ref->{link})) {
2813 if ($key =~ /\Q$module\E/) {
2815 # cross reference for keys
2816 $xkeyref{ $ref->{accno} } = $key;
2818 push @{ $self->{"${module}_links"}{$key} },
2819 { accno => $ref->{accno},
2820 description => $ref->{description},
2821 taxkey => $ref->{taxkey_id},
2822 tax_id => $ref->{tax_id} };
2824 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2830 # get taxkeys and description
2831 $query = qq|SELECT id, taxkey, taxdescription FROM tax|;
2832 $self->{TAXKEY} = selectall_hashref_query($self, $dbh, $query);
2834 if (($module eq "AP") || ($module eq "AR")) {
2835 # get tax rates and description
2836 $query = qq|SELECT * FROM tax|;
2837 $self->{TAX} = selectall_hashref_query($self, $dbh, $query);
2843 a.cp_id, a.invnumber, a.transdate, a.${table}_id, a.datepaid,
2844 a.duedate, a.ordnumber, a.taxincluded, a.curr AS currency, a.notes,
2845 a.intnotes, a.department_id, a.amount AS oldinvtotal,
2846 a.paid AS oldtotalpaid, a.employee_id, a.gldate, a.type,
2848 d.description AS department,
2851 JOIN $table c ON (a.${table}_id = c.id)
2852 LEFT JOIN employee e ON (e.id = a.employee_id)
2853 LEFT JOIN department d ON (d.id = a.department_id)
2855 $ref = selectfirst_hashref_query($self, $dbh, $query, $self->{id});
2857 foreach my $key (keys %$ref) {
2858 $self->{$key} = $ref->{$key};
2861 my $transdate = "current_date";
2862 if ($self->{transdate}) {
2863 $transdate = $dbh->quote($self->{transdate});
2866 # now get the account numbers
2867 $query = qq|SELECT c.accno, c.description, c.link, c.taxkey_id, tk.tax_id
2869 LEFT JOIN taxkeys tk ON (tk.chart_id = c.id)
2871 AND (tk.id = (SELECT id FROM taxkeys WHERE taxkeys.chart_id = c.id AND startdate <= $transdate ORDER BY startdate DESC LIMIT 1)
2872 OR c.link LIKE '%_tax%' OR c.taxkey_id IS NULL)
2875 $sth = $dbh->prepare($query);
2876 do_statement($self, $sth, $query, "%$module%");
2878 $self->{accounts} = "";
2879 while ($ref = $sth->fetchrow_hashref("NAME_lc")) {
2881 foreach my $key (split(/:/, $ref->{link})) {
2882 if ($key =~ /\Q$module\E/) {
2884 # cross reference for keys
2885 $xkeyref{ $ref->{accno} } = $key;
2887 push @{ $self->{"${module}_links"}{$key} },
2888 { accno => $ref->{accno},
2889 description => $ref->{description},
2890 taxkey => $ref->{taxkey_id},
2891 tax_id => $ref->{tax_id} };
2893 $self->{accounts} .= "$ref->{accno} " unless $key =~ /tax/;
2899 # get amounts from individual entries
2902 c.accno, c.description,
2903 a.source, a.amount, a.memo, a.transdate, a.cleared, a.project_id, a.taxkey,
2907 LEFT JOIN chart c ON (c.id = a.chart_id)
2908 LEFT JOIN project p ON (p.id = a.project_id)
2909 LEFT JOIN tax t ON (t.id= (SELECT tk.tax_id FROM taxkeys tk
2910 WHERE (tk.taxkey_id=a.taxkey) AND
2911 ((CASE WHEN a.chart_id IN (SELECT chart_id FROM taxkeys WHERE taxkey_id = a.taxkey)
2912 THEN tk.chart_id = a.chart_id
2915 OR (c.link='%tax%')) AND
2916 (startdate <= a.transdate) ORDER BY startdate DESC LIMIT 1))
2917 WHERE a.trans_id = ?
2918 AND a.fx_transaction = '0'
2919 ORDER BY a.acc_trans_id, a.transdate|;
2920 $sth = $dbh->prepare($query);
2921 do_statement($self, $sth, $query, $self->{id});
2923 # get exchangerate for currency
2924 $self->{exchangerate} =
2925 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2928 # store amounts in {acc_trans}{$key} for multiple accounts
2929 while (my $ref = $sth->fetchrow_hashref("NAME_lc")) {
2930 $ref->{exchangerate} =
2931 $self->get_exchangerate($dbh, $self->{currency}, $ref->{transdate}, $fld);
2932 if (!($xkeyref{ $ref->{accno} } =~ /tax/)) {
2935 if (($xkeyref{ $ref->{accno} } =~ /paid/) && ($self->{type} eq "credit_note")) {
2936 $ref->{amount} *= -1;
2938 $ref->{index} = $index;
2940 push @{ $self->{acc_trans}{ $xkeyref{ $ref->{accno} } } }, $ref;
2946 d.curr AS currencies, d.closedto, d.revtrans,
2947 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2948 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2950 $ref = selectfirst_hashref_query($self, $dbh, $query);
2951 map { $self->{$_} = $ref->{$_} } keys %$ref;
2958 current_date AS transdate, d.curr AS currencies, d.closedto, d.revtrans,
2959 (SELECT c.accno FROM chart c WHERE d.fxgain_accno_id = c.id) AS fxgain_accno,
2960 (SELECT c.accno FROM chart c WHERE d.fxloss_accno_id = c.id) AS fxloss_accno
2962 $ref = selectfirst_hashref_query($self, $dbh, $query);
2963 map { $self->{$_} = $ref->{$_} } keys %$ref;
2965 if ($self->{"$self->{vc}_id"}) {
2967 # only setup currency
2968 ($self->{currency}) = split(/:/, $self->{currencies});
2972 $self->lastname_used($dbh, $myconfig, $table, $module);
2974 # get exchangerate for currency
2975 $self->{exchangerate} =
2976 $self->get_exchangerate($dbh, $self->{currency}, $self->{transdate}, $fld);
2982 $main::lxdebug->leave_sub();
2986 $main::lxdebug->enter_sub();
2988 my ($self, $dbh, $myconfig, $table, $module) = @_;
2992 $table = $table eq "customer" ? "customer" : "vendor";
2993 my %column_map = ("a.curr" => "currency",
2994 "a.${table}_id" => "${table}_id",
2995 "a.department_id" => "department_id",
2996 "d.description" => "department",
2997 "ct.name" => $table,
2998 "current_date + ct.terms" => "duedate",
3001 if ($self->{type} =~ /delivery_order/) {
3002 $arap = 'delivery_orders';
3003 delete $column_map{"a.curr"};
3005 } elsif ($self->{type} =~ /_order/) {
3007 $where = "quotation = '0'";
3009 } elsif ($self->{type} =~ /_quotation/) {
3011 $where = "quotation = '1'";
3013 } elsif ($table eq 'customer') {
3021 $where = "($where) AND" if ($where);
3022 my $query = qq|SELECT MAX(id) FROM $arap
3023 WHERE $where ${table}_id > 0|;
3024 my ($trans_id) = selectrow_query($self, $dbh, $query);
3027 my $column_spec = join(', ', map { "${_} AS $column_map{$_}" } keys %column_map);
3028 $query = qq|SELECT $column_spec
3030 LEFT JOIN $table ct ON (a.${table}_id = ct.id)
3031 LEFT JOIN department d ON (a.department_id = d.id)
3033 my $ref = selectfirst_hashref_query($self, $dbh, $query, $trans_id);
3035 map { $self->{$_} = $ref->{$_} } values %column_map;
3037 $main::lxdebug->leave_sub();
3041 $main::lxdebug->enter_sub();
3044 my $myconfig = shift || \%::myconfig;
3045 my ($thisdate, $days) = @_;
3047 my $dbh = $self->get_standard_dbh($myconfig);
3052 my $dateformat = $myconfig->{dateformat};
3053 $dateformat .= "yy" if $myconfig->{dateformat} !~ /^y/;
3054 $thisdate = $dbh->quote($thisdate);
3055 $query = qq|SELECT to_date($thisdate, '$dateformat') + $days AS thisdate|;
3057 $query = qq|SELECT current_date AS thisdate|;
3060 ($thisdate) = selectrow_query($self, $dbh, $query);
3062 $main::lxdebug->leave_sub();
3068 $main::lxdebug->enter_sub();
3070 my ($self, $string) = @_;
3072 if ($string !~ /%/) {
3073 $string = "%$string%";
3076 $string =~ s/\'/\'\'/g;
3078 $main::lxdebug->leave_sub();
3084 $main::lxdebug->enter_sub();
3086 my ($self, $flds, $new, $count, $numrows) = @_;
3090 map { push @ndx, { num => $new->[$_ - 1]->{runningnumber}, ndx => $_ } } 1 .. $count;
3095 foreach my $item (sort { $a->{num} <=> $b->{num} } @ndx) {
3097 my $j = $item->{ndx} - 1;
3098 map { $self->{"${_}_$i"} = $new->[$j]->{$_} } @{$flds};
3102 for $i ($count + 1 .. $numrows) {
3103 map { delete $self->{"${_}_$i"} } @{$flds};
3106 $main::lxdebug->leave_sub();
3110 $main::lxdebug->enter_sub();
3112 my ($self, $myconfig) = @_;
3116 my $dbh = $self->dbconnect_noauto($myconfig);
3118 my $query = qq|DELETE FROM status
3119 WHERE (formname = ?) AND (trans_id = ?)|;
3120 my $sth = prepare_query($self, $dbh, $query);
3122 if ($self->{formname} =~ /(check|receipt)/) {
3123 for $i (1 .. $self->{rowcount}) {
3124 do_statement($self, $sth, $query, $self->{formname}, $self->{"id_$i"} * 1);
3127 do_statement($self, $sth, $query, $self->{formname}, $self->{id});
3131 my $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3132 my $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3134 my %queued = split / /, $self->{queued};
3137 if ($self->{formname} =~ /(check|receipt)/) {
3139 # this is a check or receipt, add one entry for each lineitem
3140 my ($accno) = split /--/, $self->{account};
3141 $query = qq|INSERT INTO status (trans_id, printed, spoolfile, formname, chart_id)
3142 VALUES (?, ?, ?, ?, (SELECT c.id FROM chart c WHERE c.accno = ?))|;
3143 @values = ($printed, $queued{$self->{formname}}, $self->{prinform}, $accno);
3144 $sth = prepare_query($self, $dbh, $query);
3146 for $i (1 .. $self->{rowcount}) {
3147 if ($self->{"checked_$i"}) {
3148 do_statement($self, $sth, $query, $self->{"id_$i"}, @values);
3154 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3155 VALUES (?, ?, ?, ?, ?)|;
3156 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed,
3157 $queued{$self->{formname}}, $self->{formname});
3163 $main::lxdebug->leave_sub();
3167 $main::lxdebug->enter_sub();
3169 my ($self, $dbh) = @_;
3171 my ($query, $printed, $emailed);
3173 my $formnames = $self->{printed};
3174 my $emailforms = $self->{emailed};
3176 $query = qq|DELETE FROM status
3177 WHERE (formname = ?) AND (trans_id = ?)|;
3178 do_query($self, $dbh, $query, $self->{formname}, $self->{id});
3180 # this only applies to the forms
3181 # checks and receipts are posted when printed or queued
3183 if ($self->{queued}) {
3184 my %queued = split / /, $self->{queued};
3186 foreach my $formname (keys %queued) {
3187 $printed = ($self->{printed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3188 $emailed = ($self->{emailed} =~ /\Q$self->{formname}\E/) ? "1" : "0";
3190 $query = qq|INSERT INTO status (trans_id, printed, emailed, spoolfile, formname)
3191 VALUES (?, ?, ?, ?, ?)|;
3192 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $queued{$formname}, $formname);
3194 $formnames =~ s/\Q$self->{formname}\E//;
3195 $emailforms =~ s/\Q$self->{formname}\E//;
3200 # save printed, emailed info
3201 $formnames =~ s/^ +//g;
3202 $emailforms =~ s/^ +//g;
3205 map { $status{$_}{printed} = 1 } split / +/, $formnames;
3206 map { $status{$_}{emailed} = 1 } split / +/, $emailforms;
3208 foreach my $formname (keys %status) {
3209 $printed = ($formnames =~ /\Q$self->{formname}\E/) ? "1" : "0";
3210 $emailed = ($emailforms =~ /\Q$self->{formname}\E/) ? "1" : "0";
3212 $query = qq|INSERT INTO status (trans_id, printed, emailed, formname)
3213 VALUES (?, ?, ?, ?)|;
3214 do_query($self, $dbh, $query, $self->{id}, $printed, $emailed, $formname);
3217 $main::lxdebug->leave_sub();
3221 # $main::locale->text('SAVED')
3222 # $main::locale->text('DELETED')
3223 # $main::locale->text('ADDED')
3224 # $main::locale->text('PAYMENT POSTED')
3225 # $main::locale->text('POSTED')
3226 # $main::locale->text('POSTED AS NEW')
3227 # $main::locale->text('ELSE')
3228 # $main::locale->text('SAVED FOR DUNNING')
3229 # $main::locale->text('DUNNING STARTED')
3230 # $main::locale->text('PRINTED')
3231 # $main::locale->text('MAILED')
3232 # $main::locale->text('SCREENED')
3233 # $main::locale->text('CANCELED')
3234 # $main::locale->text('invoice')
3235 # $main::locale->text('proforma')
3236 # $main::locale->text('sales_order')
3237 # $main::locale->text('pick_list')
3238 # $main::locale->text('purchase_order')
3239 # $main::locale->text('bin_list')
3240 # $main::locale->text('sales_quotation')
3241 # $main::locale->text('request_quotation')
3244 $main::lxdebug->enter_sub();
3247 my $dbh = shift || $self->get_standard_dbh;
3249 if(!exists $self->{employee_id}) {
3250 &get_employee($self, $dbh);
3254 qq|INSERT INTO history_erp (trans_id, employee_id, addition, what_done, snumbers) | .
3255 qq|VALUES (?, (SELECT id FROM employee WHERE login = ?), ?, ?, ?)|;
3256 my @values = (conv_i($self->{id}), $self->{login},
3257 $self->{addition}, $self->{what_done}, "$self->{snumbers}");
3258 do_query($self, $dbh, $query, @values);
3262 $main::lxdebug->leave_sub();
3266 $main::lxdebug->enter_sub();
3268 my ($self, $dbh, $trans_id, $restriction, $order) = @_;
3269 my ($orderBy, $desc) = split(/\-\-/, $order);
3270 $order = " ORDER BY " . ($order eq "" ? " h.itime " : ($desc == 1 ? $orderBy . " DESC " : $orderBy . " "));
3273 if ($trans_id ne "") {
3275 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 | .
3276 qq|FROM history_erp h | .
3277 qq|LEFT JOIN employee emp ON (emp.id = h.employee_id) | .
3278 qq|WHERE (trans_id = | . $trans_id . qq|) $restriction | .
3281 my $sth = $dbh->prepare($query) || $self->dberror($query);
3283 $sth->execute() || $self->dberror("$query");
3285 while(my $hash_ref = $sth->fetchrow_hashref()) {
3286 $hash_ref->{addition} = $main::locale->text($hash_ref->{addition});
3287 $hash_ref->{what_done} = $main::locale->text($hash_ref->{what_done});
3288 $hash_ref->{snumbers} =~ s/^.+_(.*)$/$1/g;
3289 $tempArray[$i++] = $hash_ref;
3291 $main::lxdebug->leave_sub() and return \@tempArray
3292 if ($i > 0 && $tempArray[0] ne "");
3294 $main::lxdebug->leave_sub();
3298 sub update_defaults {
3299 $main::lxdebug->enter_sub();
3301 my ($self, $myconfig, $fld, $provided_dbh) = @_;
3304 if ($provided_dbh) {
3305 $dbh = $provided_dbh;
3307 $dbh = $self->dbconnect_noauto($myconfig);
3309 my $query = qq|SELECT $fld FROM defaults FOR UPDATE|;
3310 my $sth = $dbh->prepare($query);
3312 $sth->execute || $self->dberror($query);
3313 my ($var) = $sth->fetchrow_array;
3316 if ($var =~ m/\d+$/) {
3317 my $new_var = (substr $var, $-[0]) * 1 + 1;
3318 my $len_diff = length($var) - $-[0] - length($new_var);
3319 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3325 $query = qq|UPDATE defaults SET $fld = ?|;
3326 do_query($self, $dbh, $query, $var);
3328 if (!$provided_dbh) {
3333 $main::lxdebug->leave_sub();
3338 sub update_business {
3339 $main::lxdebug->enter_sub();
3341 my ($self, $myconfig, $business_id, $provided_dbh) = @_;
3344 if ($provided_dbh) {
3345 $dbh = $provided_dbh;
3347 $dbh = $self->dbconnect_noauto($myconfig);
3350 qq|SELECT customernumberinit FROM business
3351 WHERE id = ? FOR UPDATE|;
3352 my ($var) = selectrow_query($self, $dbh, $query, $business_id);
3354 return undef unless $var;
3356 if ($var =~ m/\d+$/) {
3357 my $new_var = (substr $var, $-[0]) * 1 + 1;
3358 my $len_diff = length($var) - $-[0] - length($new_var);
3359 $var = substr($var, 0, $-[0]) . ($len_diff > 0 ? '0' x $len_diff : '') . $new_var;
3365 $query = qq|UPDATE business
3366 SET customernumberinit = ?
3368 do_query($self, $dbh, $query, $var, $business_id);
3370 if (!$provided_dbh) {
3375 $main::lxdebug->leave_sub();
3380 sub get_partsgroup {
3381 $main::lxdebug->enter_sub();
3383 my ($self, $myconfig, $p) = @_;
3384 my $target = $p->{target} || 'all_partsgroup';
3386 my $dbh = $self->get_standard_dbh($myconfig);
3388 my $query = qq|SELECT DISTINCT pg.id, pg.partsgroup
3390 JOIN parts p ON (p.partsgroup_id = pg.id) |;
3393 if ($p->{searchitems} eq 'part') {
3394 $query .= qq|WHERE p.inventory_accno_id > 0|;
3396 if ($p->{searchitems} eq 'service') {
3397 $query .= qq|WHERE p.inventory_accno_id IS NULL|;
3399 if ($p->{searchitems} eq 'assembly') {
3400 $query .= qq|WHERE p.assembly = '1'|;
3402 if ($p->{searchitems} eq 'labor') {
3403 $query .= qq|WHERE (p.inventory_accno_id > 0) AND (p.income_accno_id IS NULL)|;
3406 $query .= qq|ORDER BY partsgroup|;
3409 $query = qq|SELECT id, partsgroup FROM partsgroup
3410 ORDER BY partsgroup|;
3413 if ($p->{language_code}) {
3414 $query = qq|SELECT DISTINCT pg.id, pg.partsgroup,
3415 t.description AS translation
3417 JOIN parts p ON (p.partsgroup_id = pg.id)
3418 LEFT JOIN translation t ON ((t.trans_id = pg.id) AND (t.language_code = ?))
3419 ORDER BY translation|;
3420 @values = ($p->{language_code});
3423 $self->{$target} = selectall_hashref_query($self, $dbh, $query, @values);
3425 $main::lxdebug->leave_sub();
3428 sub get_pricegroup {
3429 $main::lxdebug->enter_sub();
3431 my ($self, $myconfig, $p) = @_;
3433 my $dbh = $self->get_standard_dbh($myconfig);
3435 my $query = qq|SELECT p.id, p.pricegroup
3438 $query .= qq| ORDER BY pricegroup|;
3441 $query = qq|SELECT id, pricegroup FROM pricegroup
3442 ORDER BY pricegroup|;
3445 $self->{all_pricegroup} = selectall_hashref_query($self, $dbh, $query);
3447 $main::lxdebug->leave_sub();
3451 # usage $form->all_years($myconfig, [$dbh])
3452 # return list of all years where bookings found
3455 $main::lxdebug->enter_sub();
3457 my ($self, $myconfig, $dbh) = @_;
3459 $dbh ||= $self->get_standard_dbh($myconfig);
3462 my $query = qq|SELECT (SELECT MIN(transdate) FROM acc_trans),
3463 (SELECT MAX(transdate) FROM acc_trans)|;
3464 my ($startdate, $enddate) = selectrow_query($self, $dbh, $query);
3466 if ($myconfig->{dateformat} =~ /^yy/) {
3467 ($startdate) = split /\W/, $startdate;
3468 ($enddate) = split /\W/, $enddate;
3470 (@_) = split /\W/, $startdate;
3472 (@_) = split /\W/, $enddate;
3477 $startdate = substr($startdate,0,4);
3478 $enddate = substr($enddate,0,4);
3480 while ($enddate >= $startdate) {
3481 push @all_years, $enddate--;
3486 $main::lxdebug->leave_sub();
3490 $main::lxdebug->enter_sub();
3494 map { $self->{_VAR_BACKUP}->{$_} = $self->{$_} if exists $self->{$_} } @vars;
3496 $main::lxdebug->leave_sub();
3500 $main::lxdebug->enter_sub();
3505 map { $self->{$_} = $self->{_VAR_BACKUP}->{$_} if exists $self->{_VAR_BACKUP}->{$_} } @vars;
3507 $main::lxdebug->leave_sub();
3516 SL::Form.pm - main data object.
3520 This is the main data object of Lx-Office.
3521 Unfortunately it also acts as a god object for certain data retrieval procedures used in the entry points.
3522 Points of interest for a beginner are:
3524 - $form->error - renders a generic error in html. accepts an error message
3525 - $form->get_standard_dbh - returns a database connection for the
3527 =head1 SPECIAL FUNCTIONS
3529 =head2 C<_store_value()>
3531 parses a complex var name, and stores it in the form.
3534 $form->_store_value($key, $value);
3536 keys must start with a string, and can contain various tokens.
3537 supported key structures are:
3540 simple key strings work as expected
3545 separating two keys by a dot (.) will result in a hash lookup for the inner value
3546 this is similar to the behaviour of java and templating mechanisms.
3548 filter.description => $form->{filter}->{description}
3550 3. array+hashref access
3552 adding brackets ([]) before the dot will cause the next hash to be put into an array.
3553 using [+] instead of [] will force a new array index. this is useful for recurring
3554 data structures like part lists. put a [+] into the first varname, and use [] on the
3557 repeating these names in your template:
3560 invoice.items[].parts_id
3564 $form->{invoice}->{items}->[
3578 using brackets at the end of a name will result in a pure array to be created.
3579 note that you mustn't use [+], which is reserved for array+hash access and will
3580 result in undefined behaviour in array context.
3582 filter.status[] => $form->{status}->[ val1, val2, ... ]
3584 =head2 C<update_business> PARAMS
3587 \%config, - config hashref
3588 $business_id, - business id
3589 $dbh - optional database handle
3591 handles business (thats customer/vendor types) sequences.
3593 special behaviour for empty strings in customerinitnumber field:
3594 will in this case not increase the value, and return undef.
3596 =head2 C<redirect_header> $url
3598 Generates a HTTP redirection header for the new C<$url>. Constructs an
3599 absolute URL including scheme, host name and port. If C<$url> is a
3600 relative URL then it is considered relative to Lx-Office base URL.
3602 This function C<die>s if headers have already been created with
3603 C<$::form-E<gt>header>.
3607 print $::form->redirect_header('oe.pl?action=edit&id=1234');
3608 print $::form->redirect_header('http://www.lx-office.org/');
3612 Generates a general purpose http/html header and includes most of the scripts
3613 ans stylesheets needed.
3615 Only one header will be generated. If the method was already called in this
3616 request it will not output anything and return undef. Also if no
3617 HTTP_USER_AGENT is found, no header is generated.
3619 Although header does not accept parameters itself, it will honor special
3620 hashkeys of its Form instance:
3628 If one of these is set, a http-equiv refresh is generated. Missing parameters
3629 default to 3 seconds and the refering url.
3635 If these are arrayrefs the contents will be inlined into the header.
3639 If true, a css snippet will be generated that sets the page in landscape mode.
3643 Used to override the default favicon.
3647 A html page title will be generated from this