X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;ds=sidebyside;f=SL%2FForm.pm;h=6d2ae491414dd264a84fad73cb033ea14aacdaf2;hb=8484285f05cdb419d89c4385d8889117bbd2df62;hp=de2028e4c30bc937fd067c50035ddec0daf05389;hpb=d71bfc9b3cd78a4a9b1c1951572af67c1e9d2925;p=kivitendo-erp.git diff --git a/SL/Form.pm b/SL/Form.pm index de2028e4c..6d2ae4914 100644 --- a/SL/Form.pm +++ b/SL/Form.pm @@ -36,6 +36,7 @@ #====================================================================== package Form; + use Data::Dumper; use CGI; @@ -53,15 +54,22 @@ use SL::Menu; use SL::Template; use SL::User; use Template; +use URI; use List::Util qw(first max min sum); +use List::MoreUtils qw(any); + +use strict; my $standard_dbh; END { - if ($standard_dbh) { - $standard_dbh->disconnect(); - undef $standard_dbh; - } + disconnect_standard_dbh(); +} + +sub disconnect_standard_dbh { + return unless $standard_dbh; + $standard_dbh->disconnect(); + undef $standard_dbh; } sub _store_value { @@ -71,30 +79,29 @@ sub _store_value { my $key = shift; my $value = shift; - my $curr = $self; + my @tokens = split /((?:\[\+?\])?(?:\.|$))/, $key; - while ($key =~ /\[\+?\]\.|\./) { - substr($key, 0, $+[0]) = ''; + my $curr; - if ($& eq '.') { - $curr->{$`} ||= { }; - $curr = $curr->{$`}; + if (scalar @tokens) { + $curr = \ $self->{ shift @tokens }; + } - } else { - $curr->{$`} ||= [ ]; - if (!scalar @{ $curr->{$`} } || $& eq '[+].') { - push @{ $curr->{$`} }, { }; - } + while (@tokens) { + my $sep = shift @tokens; + my $key = shift @tokens; - $curr = $curr->{$`}->[-1]; - } + $curr = \ $$curr->[++$#$$curr], next if $sep eq '[]'; + $curr = \ $$curr->[max 0, $#$$curr] if $sep eq '[].'; + $curr = \ $$curr->[++$#$$curr] if $sep eq '[+].'; + $curr = \ $$curr->{$key} } - $curr->{$key} = $value; + $$curr = $value; $main::lxdebug->leave_sub(2); - return \$curr->{$key}; + return $curr; } sub _input_to_hash { @@ -107,7 +114,7 @@ sub _input_to_hash { foreach (@pairs) { my ($key, $value) = split(/=/, $_, 2); - $self->_store_value($self->unescape($key), $self->unescape($value)); + $self->_store_value($self->unescape($key), $self->unescape($value)) if ($key); } $main::lxdebug->leave_sub(2); @@ -170,7 +177,7 @@ sub _request_to_hash { substr $line, $-[0], $+[0] - $-[0], ""; } - $previous = $self->_store_value($name, ''); + $previous = $self->_store_value($name, '') if ($name); $self->{FILENAME} = $filename if ($filename); next; @@ -193,6 +200,37 @@ sub _request_to_hash { $main::lxdebug->leave_sub(2); } +sub _recode_recursively { + $main::lxdebug->enter_sub(); + my ($iconv, $param) = @_; + + if (any { ref $param eq $_ } qw(Form HASH)) { + foreach my $key (keys %{ $param }) { + if (!ref $param->{$key}) { + # Workaround for a bug: converting $param->{$key} directly + # leads to 'undef'. I don't know why. Converting a copy works, + # though. + $param->{$key} = $iconv->convert("" . $param->{$key}); + } else { + _recode_recursively($iconv, $param->{$key}); + } + } + + } elsif (ref $param eq 'ARRAY') { + foreach my $idx (0 .. scalar(@{ $param }) - 1) { + if (!ref $param->[$idx]) { + # Workaround for a bug: converting $param->[$idx] directly + # leads to 'undef'. I don't know why. Converting a copy works, + # though. + $param->[$idx] = $iconv->convert("" . $param->[$idx]); + } else { + _recode_recursively($iconv, $param->[$idx]); + } + } + } + $main::lxdebug->leave_sub(); +} + sub new { $main::lxdebug->enter_sub(); @@ -205,24 +243,35 @@ sub new { tie %{ $self }, 'SL::Watchdog'; } - read(STDIN, $_, $ENV{CONTENT_LENGTH}); + bless $self, $type; + + $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING}; + $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0]; - if ($ENV{QUERY_STRING}) { - $_ = $ENV{QUERY_STRING}; + if ($ENV{CONTENT_LENGTH}) { + my $content; + read STDIN, $content, $ENV{CONTENT_LENGTH}; + $self->_request_to_hash($content); } - if ($ARGV[0]) { - $_ = $ARGV[0]; - } + my $db_charset = $main::dbcharset; + $db_charset ||= Common::DEFAULT_CHARSET; - bless $self, $type; + if ($self->{INPUT_ENCODING}) { + if (lc $self->{INPUT_ENCODING} ne lc $db_charset) { + require Text::Iconv; + my $iconv = Text::Iconv->new($self->{INPUT_ENCODING}, $db_charset); - $self->_request_to_hash($_); + _recode_recursively($iconv, $self); + } + + delete $self->{INPUT_ENCODING}; + } $self->{action} = lc $self->{action}; $self->{action} =~ s/( |-|,|\#)/_/g; - $self->{version} = "2.6.0 beta 1"; + $self->{version} = "2.6.1"; $main::lxdebug->leave_sub(); @@ -355,28 +404,33 @@ sub unescape { } sub quote { + $main::lxdebug->enter_sub(); my ($self, $str) = @_; if ($str && !ref($str)) { $str =~ s/\"/"/g; } - $str; + $main::lxdebug->leave_sub(); + return $str; } sub unquote { + $main::lxdebug->enter_sub(); my ($self, $str) = @_; if ($str && !ref($str)) { $str =~ s/"/\"/g; } - $str; + $main::lxdebug->leave_sub(); + return $str; } sub hide_form { + $main::lxdebug->enter_sub(); my $self = shift; if (@_) { @@ -387,7 +441,7 @@ sub hide_form { print($main::cgi->hidden("-name" => $_, "-default" => $self->{$_}) . "\n"); } } - + $main::lxdebug->leave_sub(); } sub error { @@ -401,8 +455,8 @@ sub error { $self->show_generic_error($msg); } else { - - die "Error: $msg\n"; + print STDERR "Error: $msg\n"; + ::end_of_request(); } $main::lxdebug->leave_sub(); @@ -481,6 +535,40 @@ sub isblank { $main::lxdebug->leave_sub(); } +sub _get_request_uri { + my $self = shift; + + return URI->new($ENV{HTTP_REFERER})->canonical() if $ENV{HTTP_X_FORWARDED_FOR}; + + my $scheme = $ENV{HTTPS} && (lc $ENV{HTTPS} eq 'on') ? 'https' : 'http'; + my $port = $ENV{SERVER_PORT} || ''; + $port = undef if (($scheme eq 'http' ) && ($port == 80)) + || (($scheme eq 'https') && ($port == 443)); + + my $uri = URI->new("${scheme}://"); + $uri->scheme($scheme); + $uri->port($port); + $uri->host($ENV{HTTP_HOST} || $ENV{SERVER_ADDR}); + $uri->path_query($ENV{REQUEST_URI}); + $uri->query(''); + + return $uri; +} + +sub _add_to_request_uri { + my $self = shift; + + my $relative_new_path = shift; + my $request_uri = shift || $self->_get_request_uri; + my $relative_new_uri = URI->new($relative_new_path); + my @request_segments = $request_uri->path_segments; + + my $new_uri = $request_uri->clone; + $new_uri->path_segments(@request_segments[0..scalar(@request_segments) - 2], $relative_new_uri->path_segments); + + return $new_uri; +} + sub create_http_response { $main::lxdebug->enter_sub(); @@ -490,25 +578,20 @@ sub create_http_response { my $cgi = $main::cgi; $cgi ||= CGI->new(''); - my $base_path; - - if ($ENV{HTTP_X_FORWARDED_FOR}) { - $base_path = $ENV{HTTP_REFERER}; - $base_path =~ s|^.*?://.*?/|/|; - } else { - $base_path = $ENV{REQUEST_URI}; - } - $base_path =~ s|[^/]+$||; - $base_path =~ s|/$||; - my $session_cookie; if (defined $main::auth) { + my $uri = $self->_get_request_uri; + my @segments = $uri->path_segments; + pop @segments; + $uri->path_segments(@segments); + my $session_cookie_value = $main::auth->get_session_id(); $session_cookie_value ||= 'NO_SESSION'; - $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(), - '-value' => $session_cookie_value, - '-path' => $base_path); + $session_cookie = $cgi->cookie('-name' => $main::auth->get_session_cookie_name(), + '-value' => $session_cookie_value, + '-path' => $uri->path, + '-secure' => $ENV{HTTPS}); } my %cgi_params = ('-type' => $params{content_type}); @@ -526,6 +609,8 @@ sub create_http_response { sub header { $main::lxdebug->enter_sub(); + # extra code ist currently only used by menuv3 and menuv4 to set their css. + # it is strongly deprecated, and will be changed in a future version. my ($self, $extra_code) = @_; if ($self->{header}) { @@ -570,13 +655,22 @@ sub header { |; } - my $fokus = qq| document.$self->{fokus}.focus();| if ($self->{"fokus"}); + my $fokus = qq| + + | if $self->{"fokus"}; #Set Calendar my $jsscript = ""; if ($self->{jsscript} == 1) { $jsscript = qq| + @@ -591,7 +685,7 @@ sub header { ? "$self->{title} - $self->{titlebar}" : $self->{titlebar}; my $ajax = ""; - foreach my $item (@ { $self->{AJAX} }) { + for my $item (@ { $self->{AJAX} || [] }) { $ajax .= $item->show_javascript(); } @@ -607,13 +701,9 @@ sub header { $jsscript $ajax - + $fokus + + @@ -653,38 +743,59 @@ sub ajax_response_header { return $output; } +sub redirect_header { + my $self = shift; + my $new_url = shift; + + my $base_uri = $self->_get_request_uri; + my $new_uri = URI->new_abs($new_url, $base_uri); + + die "Headers already sent" if $::self->{header}; + $self->{header} = 1; + + my $cgi = $main::cgi || CGI->new(''); + return $cgi->redirect($new_uri); +} + +sub set_standard_title { + $::lxdebug->enter_sub; + my $self = shift; + + $self->{titlebar} = "Lx-Office " . $::locale->text('Version') . " $self->{version}"; + $self->{titlebar} .= "- $::myconfig{name}" if $::myconfig{name}; + $self->{titlebar} .= "- $::myconfig{dbname}" if $::myconfig{name}; + + $::lxdebug->leave_sub; +} + sub _prepare_html_template { $main::lxdebug->enter_sub(); my ($self, $file, $additional_params) = @_; my $language; - if (!defined(%main::myconfig) || !defined($main::myconfig{"countrycode"})) { + if (!%::myconfig || !$::myconfig{"countrycode"}) { $language = $main::language; } else { $language = $main::myconfig{"countrycode"}; } $language = "de" unless ($language); - if (-f "templates/webpages/${file}_${language}.html") { - if ((-f ".developer") && - (-f "templates/webpages/${file}_master.html") && - ((stat("templates/webpages/${file}_master.html"))[9] > - (stat("templates/webpages/${file}_${language}.html"))[9])) { - my $info = "Developer information: templates/webpages/${file}_master.html is newer than the localized version.\n" . + if (-f "templates/webpages/${file}.html") { + if ((-f ".developer") && ((stat("templates/webpages/${file}.html"))[9] > (stat("locale/${language}/all"))[9])) { + my $info = "Developer information: templates/webpages/${file}.html is newer than the translation file locale/${language}/all.\n" . "Please re-run 'locales.pl' in 'locale/${language}'."; print(qq|
$info|); - die($info); + ::end_of_request(); } - $file = "templates/webpages/${file}_${language}.html"; - } elsif (-f "templates/webpages/${file}.html") { $file = "templates/webpages/${file}.html"; + } else { my $info = "Web page template '${file}' not found.\n" . "Please re-run 'locales.pl' in 'locale/${language}'."; print(qq|
$info|); - die($info); + ::end_of_request(); } if ($self->{"DEBUG"}) { @@ -703,6 +814,7 @@ sub _prepare_html_template { $jsc_dateformat =~ s/m+/\%m/gi; $jsc_dateformat =~ s/y+/\%Y/gi; $additional_params->{"myconfig_jsc_dateformat"} = $jsc_dateformat; + $additional_params->{"myconfig"} ||= \%::myconfig; } $additional_params->{"conf_dbcharset"} = $main::dbcharset; @@ -710,6 +822,8 @@ sub _prepare_html_template { $additional_params->{"conf_lizenzen"} = $main::lizenzen; $additional_params->{"conf_latex_templates"} = $main::latex; $additional_params->{"conf_opendocument_templates"} = $main::opendocument_templates; + $additional_params->{"conf_vertreter"} = $main::vertreter; + $additional_params->{"conf_show_best_before"} = $main::show_best_before; if (%main::debug_options) { map { $additional_params->{'DEBUG_' . uc($_)} = $main::debug_options{$_} } keys %main::debug_options; @@ -741,29 +855,14 @@ sub parse_html_template { 'CACHE_SIZE' => 0, 'PLUGIN_BASE' => 'SL::Template::Plugin', 'INCLUDE_PATH' => '.:templates/webpages', + 'COMPILE_EXT' => $main::template_compile_ext, + 'COMPILE_DIR' => $main::template_compile_dir, }) || die; map { $additional_params->{$_} ||= $self->{$_} } keys %{ $self }; - my $in = IO::File->new($file, 'r'); - - if (!$in) { - print STDERR "Error opening template file: $!"; - $main::lxdebug->leave_sub(); - return ''; - } - - my $input = join('', <$in>); - $in->close(); - - if ($main::locale) { - $input = $main::locale->{iconv}->convert($input); - } - my $output; - if (!$template->process(\$input, $additional_params, \$output)) { - print STDERR $template->error(); - } + $template->process($file, $additional_params, \$output) || die $template->error(); $main::lxdebug->leave_sub(); @@ -799,9 +898,11 @@ sub show_generic_error { $self->header(); print $self->parse_html_template("generic/error", $add_params); + print STDERR "Error: $error\n"; + $main::lxdebug->leave_sub(); - die("Error: $error\n"); + ::end_of_request(); } sub show_generic_information { @@ -821,7 +922,7 @@ sub show_generic_information { $main::lxdebug->leave_sub(); - die("Information: $text\n"); + ::end_of_request(); } # write Trigger JavaScript-Code ($qty = quantity of Triggers) @@ -876,19 +977,19 @@ sub redirect { my ($self, $msg) = @_; - if ($self->{callback}) { - - my ($script, $argv) = split(/\?/, $self->{callback}, 2); - $script =~ s|.*/||; - $script =~ s|[^a-zA-Z0-9_\.]||g; - exec("perl", "$script", $argv); - - } else { + if (!$self->{callback}) { $self->info($msg); - exit; + ::end_of_request(); } +# my ($script, $argv) = split(/\?/, $self->{callback}, 2); +# $script =~ s|.*/||; +# $script =~ s|[^a-zA-Z0-9_\.]||g; +# exec("perl", "$script", $argv); + + print $::form->redirect_header($self->{callback}); + $main::lxdebug->leave_sub(); } @@ -911,12 +1012,12 @@ sub format_amount { if ($amount eq "") { $amount = 0; } - + # Hey watch out! The amount can be an exponential term like 1.13686837721616e-13 - + my $neg = ($amount =~ s/^-//); my $exp = ($amount =~ m/[e]/) ? 1 : 0; - + if (defined($places) && ($places ne '')) { if (not $exp) { if ($places < 0) { @@ -940,9 +1041,9 @@ sub format_amount { $amount .= $d[0].$p[1].(0 x ($places - length $p[1])) if ($places || $p[1] ne ''); $amount = do { - ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) : - ($dash =~ /DRCR/) ? ($neg ? "$amount DR" : "$amount CR" ) : - ($neg ? "-$amount" : "$amount" ) ; + ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) : + ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) : + ($neg ? "-$amount" : "$amount" ) ; }; @@ -1064,13 +1165,13 @@ sub round_amount { my ($self, $amount, $places) = @_; my $round_amount; - # Rounding like "Kaufmannsrunden" - # Descr. http://de.wikipedia.org/wiki/Rundung - # Inspired by - # http://www.perl.com/doc/FAQs/FAQ/oldfaq-html/Q4.13.html - # Solves Bug: 189 - # Udo Spallek - $amount = $amount * (10**($places)); + # Rounding like "Kaufmannsrunden" (see http://de.wikipedia.org/wiki/Rundung ) + + # Round amounts to eight places before rounding to the requested + # number of places. This gets rid of errors due to internal floating + # point representation. + $amount = $self->round_amount($amount, 8) if $places < 8; + $amount = $amount * (10**($places)); $round_amount = int($amount + .5 * ($amount <=> 0)) / (10**($places)); $main::lxdebug->leave_sub(2); @@ -1090,25 +1191,41 @@ sub parse_template { $self->{"cwd"} = getcwd(); $self->{"tmpdir"} = $self->{cwd} . "/${userspath}"; + my $ext_for_format; + if ($self->{"format"} =~ /(opendocument|oasis)/i) { - $template = OpenDocumentTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $template = OpenDocumentTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $ext_for_format = $self->{"format"} =~ m/pdf/ ? 'pdf' : 'odt'; + } elsif ($self->{"format"} =~ /(postscript|pdf)/i) { $ENV{"TEXINPUTS"} = ".:" . getcwd() . "/" . $myconfig->{"templates"} . ":" . $ENV{"TEXINPUTS"}; - $template = LaTeXTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); - } elsif (($self->{"format"} =~ /html/i) || - (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) { - $template = HTMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); - } elsif (($self->{"format"} =~ /xml/i) || - (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) { - $template = XMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $template = LaTeXTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $ext_for_format = 'pdf'; + + } elsif (($self->{"format"} =~ /html/i) || (!$self->{"format"} && ($self->{"IN"} =~ /html$/i))) { + $template = HTMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $ext_for_format = 'html'; + + } elsif (($self->{"format"} =~ /xml/i) || (!$self->{"format"} && ($self->{"IN"} =~ /xml$/i))) { + $template = XMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $ext_for_format = 'xml'; + } elsif ( $self->{"format"} =~ /elsterwinston/i ) { $template = XMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + } elsif ( $self->{"format"} =~ /elstertaxbird/i ) { $template = XMLTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + + } elsif ( $self->{"format"} =~ /excel/i ) { + $template = ExcelTemplate->new($self->{"IN"}, $self, $myconfig, $userspath); + $ext_for_format = 'xls'; + } elsif ( defined $self->{'format'}) { $self->error("Outputformat not defined. This may be a future feature: $self->{'format'}"); + } elsif ( $self->{'format'} eq '' ) { $self->error("No Outputformat given: $self->{'format'}"); + } else { #Catch the rest $self->error("Outputformat not defined: $self->{'format'}"); } @@ -1145,20 +1262,23 @@ sub parse_template { $self->{OUT} = ">$self->{tmpfile}"; } + my $result; + if ($self->{OUT}) { - open(OUT, "$self->{OUT}") or $self->error("$self->{OUT} : $!"); + open OUT, "$self->{OUT}" or $self->error("$self->{OUT} : $!"); + $result = $template->parse(*OUT); + close OUT; + } else { - open(OUT, ">-") or $self->error("STDOUT : $!"); $self->header; + $result = $template->parse(*STDOUT); } - if (!$template->parse(*OUT)) { + if (!$result) { $self->cleanup(); $self->error("$self->{IN} : " . $template->get_error()); } - close(OUT); - if ($template->uses_temp_file() || $self->{media} eq 'email') { if ($self->{media} eq 'email') { @@ -1193,10 +1313,10 @@ sub parse_template { } else { if (!$self->{"do_not_attach"}) { - @{ $mail->{attachments} } = - ({ "filename" => $self->{"tmpfile"}, - "name" => $self->{"attachment_filename"} ? - $self->{"attachment_filename"} : $self->{"tmpfile"} }); + my $attachment_name = $self->{attachment_filename} || $self->{tmpfile}; + $attachment_name =~ s/\.(.+?)$/.${ext_for_format}/ if ($ext_for_format); + $mail->{attachments} = [{ "filename" => $self->{tmpfile}, + "name" => $attachment_name }]; } $mail->{message} =~ s/\r//g; @@ -1222,10 +1342,13 @@ sub parse_template { #print(STDERR "OUT $self->{OUT}\n"); for my $i (1 .. $self->{copies}) { if ($self->{OUT}) { - open(OUT, $self->{OUT}) - or $self->error($self->cleanup . "$self->{OUT} : $!"); + open OUT, $self->{OUT} or $self->error($self->cleanup . "$self->{OUT} : $!"); + print OUT while