X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=SL%2FForm.pm;h=b0e25d70daf1301223d6758d6182810a74f5d960;hb=f41c4ade2c9d496a3362037d3ee0a1500987e4d6;hp=ca8d4fc22841c82fc669ec261ad9eb9493cf3811;hpb=f59ed16fa072d31e5d9190d1b1b0b917b7ac39f3;p=kivitendo-erp.git diff --git a/SL/Form.pm b/SL/Form.pm index ca8d4fc22..b0e25d70d 100644 --- a/SL/Form.pm +++ b/SL/Form.pm @@ -54,6 +54,7 @@ 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); @@ -62,10 +63,13 @@ 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 { @@ -239,20 +243,17 @@ sub new { tie %{ $self }, 'SL::Watchdog'; } - read(STDIN, $_, $ENV{CONTENT_LENGTH}); + bless $self, $type; - if ($ENV{QUERY_STRING}) { - $_ = $ENV{QUERY_STRING}; - } + $self->_input_to_hash($ENV{QUERY_STRING}) if $ENV{QUERY_STRING}; + $self->_input_to_hash($ARGV[0]) if @ARGV && $ARGV[0]; - if ($ARGV[0]) { - $_ = $ARGV[0]; + if ($ENV{CONTENT_LENGTH}) { + my $content; + read STDIN, $content, $ENV{CONTENT_LENGTH}; + $self->_request_to_hash($content); } - bless $self, $type; - - $self->_request_to_hash($_); - my $db_charset = $main::dbcharset; $db_charset ||= Common::DEFAULT_CHARSET; @@ -270,7 +271,7 @@ sub new { $self->{action} = lc $self->{action}; $self->{action} =~ s/( |-|,|\#)/_/g; - $self->{version} = "2.6.1 Beta 1"; + $self->{version} = "2.6.1"; $main::lxdebug->leave_sub(); @@ -454,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(); @@ -534,6 +535,26 @@ 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 create_http_response { $main::lxdebug->enter_sub(); @@ -543,25 +564,19 @@ 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, + '-path' => $uri->path, '-secure' => $ENV{HTTPS}); } @@ -656,7 +671,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(); } @@ -714,6 +729,31 @@ 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(); @@ -727,25 +767,21 @@ sub _prepare_html_template { } $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"}) { @@ -764,6 +800,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; @@ -819,10 +856,6 @@ sub parse_html_template { 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(); @@ -862,9 +895,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 { @@ -884,7 +919,7 @@ sub show_generic_information { $main::lxdebug->leave_sub(); - die("Information: $text\n"); + ::end_of_request(); } # write Trigger JavaScript-Code ($qty = quantity of Triggers) @@ -939,19 +974,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(); } @@ -1178,6 +1213,10 @@ sub parse_template { } 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'}"); @@ -1220,20 +1259,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') { @@ -1297,8 +1339,11 @@ 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 ; + close OUT; + seek IN, 0, 0; + } else { $self->{attachment_filename} = ($self->{attachment_filename}) ? $self->{attachment_filename} @@ -1311,18 +1356,8 @@ Content-Length: $numbytes |; - open(OUT, ">-") or $self->error($self->cleanup . "$!: STDOUT"); - - } - - while () { - print OUT $_; - + $::locale->with_raw_io(\*STDOUT, sub { print while }); } - - close(OUT); - - seek IN, 0, 0; } close(IN); @@ -1385,6 +1420,7 @@ sub get_extension_for_format { my $extension = $self->{format} =~ /pdf/i ? ".pdf" : $self->{format} =~ /postscript/i ? ".ps" : $self->{format} =~ /opendocument/i ? ".odt" + : $self->{format} =~ /excel/i ? ".xls" : $self->{format} =~ /html/i ? ".html" : ""; @@ -1813,6 +1849,7 @@ sub set_payment_options { $amounts{invtotal} = $self->{invtotal}; $amounts{total} = $self->{total}; } + $amounts{skonto_in_percent} = 100.0 * $self->{percent_skonto}; map { $amounts{$_} = $self->parse_amount($myconfig, $amounts{$_}) } keys %amounts; @@ -1866,6 +1903,8 @@ sub set_payment_options { map { $self->{payment_terms} =~ s/<%${_}%>/$formatted_amounts{$_}/g; } keys %formatted_amounts; + $self->{skonto_in_percent} = $formatted_amounts{skonto_in_percent}; + $main::lxdebug->leave_sub(); } @@ -3541,6 +3580,20 @@ handles business (thats customer/vendor types) sequences. special behaviour for empty strings in customerinitnumber field: will in this case not increase the value, and return undef. +=item redirect_header $url + +Generates a HTTP redirection header for the new C<$url>. Constructs an +absolute URL including scheme, host name and port. If C<$url> is a +relative URL then it is considered relative to Lx-Office base URL. + +This function Cs if headers have already been created with +C<$::form-Eheader>. + +Examples: + + print $::form->redirect_header('oe.pl?action=edit&id=1234'); + print $::form->redirect_header('http://www.lx-office.org/'); + =back =cut