X-Git-Url: http://mj.ucw.cz/gitweb/?a=blobdiff_plain;f=ucw%2Fperl%2FUCW%2FCGI.pm;h=f81bd3ea300da22776457a5cf0b52ed34f17791b;hb=0192d9f3a127c82b32131d26ed9b5fb5a90db723;hp=af5e2c5c6a33d7b824bc2d8b1e9952615d1875b5;hpb=3da35cffa27f520c30599005be34c7e8049eb2ad;p=libucw.git diff --git a/ucw/perl/UCW/CGI.pm b/ucw/perl/UCW/CGI.pm index af5e2c5c..f81bd3ea 100644 --- a/ucw/perl/UCW/CGI.pm +++ b/ucw/perl/UCW/CGI.pm @@ -1,56 +1,13 @@ # Poor Man's CGI Module for Perl # -# (c) 2002--2009 Martin Mares +# (c) 2002--2011 Martin Mares # Slightly modified by Tomas Valla # # This software may be freely distributed and used according to the terms # of the GNU Lesser General Public License. -# FIXME: -# - respond with proper HTTP error codes -# - if we get invalid parameters, generate HTTP error or redirect - package UCW::CGI; -# First of all, set up error handling, so that even errors during parsing -# will be reported properly. - -# Variables to be set by the calling module: -# $UCW::CGI::error_mail mail address of the script admin (optional) -# (this one has to be set in the BEGIN block!) -# $UCW::CGI::error_hook function to be called for reporting errors - -my $error_reported; -my $exit_code; -my $debug = 0; - -sub report_bug($) -{ - if (!defined $error_reported) { - $error_reported = 1; - print STDERR $_[0]; - if (defined($UCW::CGI::error_hook)) { - &$UCW::CGI::error_hook($_[0]); - } else { - print "Content-type: text/plain\n\n"; - print "Internal bug:\n"; - print $_[0], "\n"; - print "Please notify $UCW::CGI::error_mail\n" if defined $UCW::CGI::error_mail; - } - } - die; -} - -BEGIN { - $SIG{__DIE__} = sub { report_bug($_[0]); }; - $SIG{__WARN__} = sub { report_bug("WARNING: " . $_[0]); }; - $exit_code = 0; -} - -END { - $? = $exit_code; -} - use strict; use warnings; @@ -60,22 +17,39 @@ our @ISA = qw(Exporter); our @EXPORT = qw(&html_escape &url_escape &url_deescape &url_param_escape &url_param_deescape &self_ref &self_form &http_get); our @EXPORT_OK = qw(); +# Configuration settings +our $debug = 0; +our $utf8_mode = 0; + +sub http_error($;@) { + my $err = shift @_; + print join("\n", "Status: $err", "Content-Type: text/plain", @_, "", $err, ""); + exit; +} + ### Escaping ### sub url_escape($) { my $x = shift @_; + defined $x or return; + utf8::encode($x) if $utf8_mode; $x =~ s/([^-\$_.!*'(),0-9A-Za-z\x80-\xff])/"%".unpack('H2',$1)/ge; + utf8::decode($x) if $utf8_mode; return $x; } sub url_deescape($) { my $x = shift @_; + defined $x or return; + utf8::encode($x) if $utf8_mode; $x =~ s/%(..)/pack("H2",$1)/ge; + utf8::decode($x) if $utf8_mode; return $x; } sub url_param_escape($) { my $x = shift @_; + defined $x or return; $x = url_escape($x); $x =~ s/%20/+/g; return $x; @@ -83,16 +57,19 @@ sub url_param_escape($) { sub url_param_deescape($) { my $x = shift @_; + defined $x or return; $x =~ s/\+/ /g; return url_deescape($x); } sub html_escape($) { my $x = shift @_; + defined $x or return; $x =~ s/&/&/g; $x =~ s//>/g; $x =~ s/"/"/g; + $x =~ s/'/'/g; return $x; } @@ -125,7 +102,7 @@ sub rfc822_deescape($) { sub http_get($) { my $h = shift @_; $h =~ tr/a-z-/A-Z_/; - return $ENV{"HTTP_$h"} || $ENV{"$h"}; + return $ENV{"HTTP_$h"} // $ENV{"$h"}; } ### Parsing of Arguments ### @@ -133,6 +110,14 @@ sub http_get($) { my $main_arg_table; my %raw_args; +sub parse_raw_args_ll($$) { + my ($arg, $s) = @_; + $s =~ s/\r\n/\n/g; + $s =~ s/\r/\n/g; + utf8::decode($s) if $utf8_mode; + push @{$raw_args{$arg}}, $s; +} + sub parse_raw_args($) { my ($s) = @_; $s =~ s/\s+//; @@ -142,9 +127,7 @@ sub parse_raw_args($) { $_ = $2; s/\+/ /g; s/%(..)/pack("H2",$1)/eg; - s/\r\n/\n/g; - s/\r/\n/g; - $raw_args{$arg} = $_; + parse_raw_args_ll($arg, $_); } } @@ -153,7 +136,7 @@ sub parse_multipart_form_data(); sub init_args() { if (!defined $ENV{"GATEWAY_INTERFACE"}) { print STDERR "Must be called as a CGI script.\n"; - $exit_code = 1; + $UCW::CGI::ErrorHandler::exit_code = 1; exit; } @@ -161,20 +144,22 @@ sub init_args() { if (my $qs = $ENV{"QUERY_STRING"}) { parse_raw_args($qs); } - if ($method eq "GET") { + if ($method eq "GET" || $method eq "HEAD") { } elsif ($method eq "POST") { - if ($ENV{"CONTENT_TYPE"} =~ /^application\/x-www-form-urlencoded\b/i) { + my $content_type = $ENV{"CONTENT_TYPE"} // ""; + if ($content_type =~ /^application\/x-www-form-urlencoded\b/i) { while () { chomp; parse_raw_args($_); } - } elsif ($ENV{"CONTENT_TYPE"} =~ /^multipart\/form-data\b/i) { + } elsif ($content_type =~ /^multipart\/form-data\b/i) { parse_multipart_form_data(); } else { - die "Unknown content type for POST data"; + http_error "415 Unsupported Media Type"; + exit; } } else { - die "Unknown request method"; + http_error "405 Method Not Allowed", "Allow: GET, HEAD, POST"; } } @@ -187,7 +172,7 @@ sub parse_args($) { # CAVEAT: attached files must be defined in the main arg t for my $a (values %$args) { my $r = ref($a->{'var'}); - defined($a->{'default'}) or $a->{'default'}=""; + $a->{'default'} //= ''; if ($r eq 'SCALAR') { ${$a->{'var'}} = $a->{'default'}; } elsif ($r eq 'ARRAY') { @@ -195,22 +180,24 @@ sub parse_args($) { # CAVEAT: attached files must be defined in the main arg t } } - for my $a (values %$args) { - defined($raw_args{$a}) or next; - $_ = $raw_args{$a}; - $a->{'multiline'} or s/(\n|\t)/ /g; - s/^\s+//; - s/\s+$//; - if (my $rx = $a->{'check'}) { - if (!/^$rx$/) { $_ = $a->{'default'}; } - } + for my $arg (keys %$args) { + my $a = $args->{$arg}; + defined($raw_args{$arg}) or next; + for (@{$raw_args{$arg}}) { + $a->{'multiline'} or s/(\n|\t)/ /g; + s/^\s+//; + s/\s+$//; + if (my $rx = $a->{'check'}) { + if (!/^$rx$/) { $_ = $a->{'default'}; } + } - my $v = $a->{'var'}; - my $r = ref($v); - if ($r eq 'SCALAR') { - $$v = $_; - } elsif ($r eq 'ARRAY') { - push @$v, $_; + my $v = $a->{'var'}; + my $r = ref($v); + if ($r eq 'SCALAR') { + $$v = $_; + } elsif ($r eq 'ARRAY') { + push @$v, $_; + } } } } @@ -273,13 +260,13 @@ sub get_mp_line($) { return undef; } } else { - die "Premature end of multipart POST data"; + http_error "400 Bad Request: Premature end of multipart POST data"; } } sub skip_mp_boundary() { if ($mp_buffer_boundary != $mp_buffer_i) { - die "Premature end of multipart POST data"; + http_error "400 Bad Request: Premature end of multipart POST data"; } $mp_buffer_boundary = -1; $mp_buffer_i += 2; @@ -318,15 +305,15 @@ sub parse_mp_header() { sub parse_multipart_form_data() { # First of all, find the boundary string my $ct = rfc822_prepare($ENV{"CONTENT_TYPE"}); - if (!(($boundary) = ($ct =~ /^.*;boundary=([^; ]+)/))) { - die "Multipart content with no boundary string received"; + if (!(($boundary) = ($ct =~ /^.*;\s*boundary=([^; ]+)/))) { + http_error "400 Bad Request: Multipart content with no boundary string received"; } $boundary = rfc822_deescape($boundary); print STDERR "BOUNDARY IS $boundary\n" if $debug; # BUG: IE 3.01 on Macintosh forgets to add the "--" at the start of the boundary string # as the MIME specs preach. Workaround borrowed from CGI.pm in Perl distribution. - my $agent = http_get("User-agent") || ""; + my $agent = http_get("User-Agent") // ""; $boundary = "--$boundary" unless $agent =~ /MSIE\s+3\.0[12];\s*Mac/; $boundary = "\r\n$boundary"; $boundary_len = length($boundary) + 2; @@ -338,7 +325,7 @@ sub parse_multipart_form_data() { $max_allowed += $a->{"maxsize"} || 65536; } if ($size > $max_allowed) { - die "Maximum form data length exceeded"; + http_error "413 Request Entity Too Large"; } } @@ -363,11 +350,13 @@ sub parse_multipart_form_data() { (($field) = ($cdisp =~ /;name=([^;]+)/)) && ($a = $main_arg_table->{"$field"})) { print STDERR "FIELD $field\n" if $debug; - if (defined $h->{"content-transfer-encoding"}) { die "Unexpected Content-Transfer-Encoding"; } + if (defined $h->{"content-transfer-encoding"}) { + http_error "400 Bad Request: Unexpected Content-Transfer-Encoding"; + } if (defined $a->{"var"}) { while (defined (my $l = get_mp_line(1))) { print STDERR "VALUE $l\n" if $debug; - parse_raw_args("$field=$l"); + parse_raw_args_ll($field, $l); } next PART; } elsif (defined $a->{"file"}) { @@ -385,7 +374,7 @@ sub parse_multipart_form_data() { print $fh substr($mp_buffer, $mp_buffer_i, $i); $mp_buffer_i += $i; $total_size += $i; - if ($total_size > $max_size) { die "Uploaded file too long"; } + if ($total_size > $max_size) { http_error "413 Request Entity Too Large"; } } $fh->flush(); # Don't close the handle, the file would disappear otherwise next PART; @@ -400,7 +389,7 @@ sub parse_multipart_form_data() { sub make_out_args(@) { # Usage: make_out_args([arg_table, ...] name => value, ...) my @arg_tables = ( $main_arg_table ); - while (@_ && ref(@_) eq 'HASH') { + while (@_ && ref($_[0]) eq 'HASH') { push @arg_tables, shift @_; } my %overrides = @_; @@ -410,12 +399,14 @@ sub make_out_args(@) { # Usage: make_out_args([arg_table, ...] name => value, . my $arg = $table->{$name}; defined($arg->{'var'}) || next; defined($arg->{'pass'}) && !$arg->{'pass'} && !exists $overrides{$name} && next; + defined $arg->{'default'} or $arg->{'default'} = ""; my $value; if (!defined($value = $overrides{$name})) { if (exists $overrides{$name}) { $value = $arg->{'default'}; } else { $value = ${$arg->{'var'}}; + defined $value or $value = $arg->{'default'}; } } if ($value ne $arg->{'default'}) {