X-Git-Url: http://mj.ucw.cz/gitweb/?a=blobdiff_plain;f=ucw%2Fperl%2FUCW%2FCGI.pm;h=73238a5be3413f2b246867c3608f42e57e6da316;hb=b074a6e247a4723fbd84d72445949813c8b7420b;hp=99ab83a9ffc2eb7705b892e7fb5791feeeb5cb48;hpb=ad920945145a18895ef391511c92ef42e0e4c3d7;p=libucw.git diff --git a/ucw/perl/UCW/CGI.pm b/ucw/perl/UCW/CGI.pm index 99ab83a9..73238a5b 100644 --- a/ucw/perl/UCW/CGI.pm +++ b/ucw/perl/UCW/CGI.pm @@ -1,6 +1,6 @@ # Poor Man's CGI Module for Perl # -# (c) 2002--2007 Martin Mares +# (c) 2002--2010 Martin Mares # Slightly modified by Tomas Valla # # This software may be freely distributed and used according to the terms @@ -60,17 +60,23 @@ 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(); +our $utf8_mode = 0; + ### Escaping ### sub url_escape($) { my $x = shift @_; + 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 @_; + utf8::encode($x) if $utf8_mode; $x =~ s/%(..)/pack("H2",$1)/ge; + utf8::decode($x) if $utf8_mode; return $x; } @@ -93,6 +99,7 @@ sub html_escape($) { $x =~ s//>/g; $x =~ s/"/"/g; + $x =~ s/'/'/g; return $x; } @@ -130,62 +137,49 @@ sub http_get($) { ### Parsing of Arguments ### -my $arg_table; +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_arg_string($) { +sub parse_raw_args($) { my ($s) = @_; $s =~ s/\s+//; - foreach $_ (split /[&:]/,$s) { + for $_ (split /[&:]/, $s) { (/^([^=]+)=(.*)$/) or next; - my $arg = $arg_table->{$1} or next; + my $arg = $1; $_ = $2; s/\+/ /g; s/%(..)/pack("H2",$1)/eg; - s/\r\n/\n/g; - s/\r/\n/g; - $arg->{'multiline'} || s/(\n|\t)/ /g; - s/^\s+//; - s/\s+$//; - if (my $rx = $arg->{'check'}) { - if (!/^$rx$/) { $_ = $arg->{'default'}; } - } - - my $r = ref($arg->{'var'}); - if ($r eq 'SCALAR') { - ${$arg->{'var'}} = $_; - } elsif ($r eq 'ARRAY') { - push @{$arg->{'var'}}, $_; - } + parse_raw_args_ll($arg, $_); } } sub parse_multipart_form_data(); -sub parse_args($) { - $arg_table = shift @_; +sub init_args() { if (!defined $ENV{"GATEWAY_INTERFACE"}) { print STDERR "Must be called as a CGI script.\n"; $exit_code = 1; exit; } - foreach my $a (values %$arg_table) { - my $r = ref($a->{'var'}); - defined($a->{'default'}) or $a->{'default'}=""; - if ($r eq 'SCALAR') { - ${$a->{'var'}} = $a->{'default'}; - } elsif ($r eq 'ARRAY') { - @{$a->{'var'}} = (); - } - } + my $method = $ENV{"REQUEST_METHOD"}; - my $qs = $ENV{"QUERY_STRING"}; - parse_arg_string($qs) if defined($qs); + if (my $qs = $ENV{"QUERY_STRING"}) { + parse_raw_args($qs); + } if ($method eq "GET") { } elsif ($method eq "POST") { if ($ENV{"CONTENT_TYPE"} =~ /^application\/x-www-form-urlencoded\b/i) { while () { chomp; - parse_arg_string($_); + parse_raw_args($_); } } elsif ($ENV{"CONTENT_TYPE"} =~ /^multipart\/form-data\b/i) { parse_multipart_form_data(); @@ -197,6 +191,45 @@ sub parse_args($) { } } +sub parse_args($) { # CAVEAT: attached files must be defined in the main arg table + my $args = shift @_; + if (!$main_arg_table) { + $main_arg_table = $args; + init_args(); + } + + for my $a (values %$args) { + my $r = ref($a->{'var'}); + defined($a->{'default'}) or $a->{'default'}=""; + if ($r eq 'SCALAR') { + ${$a->{'var'}} = $a->{'default'}; + } elsif ($r eq 'ARRAY') { + @{$a->{'var'}} = (); + } + } + + 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, $_; + } + } + } +} + ### Parsing Multipart Form Data ### my $boundary; @@ -268,7 +301,7 @@ sub skip_mp_boundary() { my $b = get_mp_line(0); print STDERR "SEP $b\n" if $debug; $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i); - if ("\r\n$b" =~ /^$boundary--/) { + if (substr("\r\n$b", 0, $boundary_len) eq "$boundary--") { return 0; } else { return 1; @@ -316,7 +349,7 @@ sub parse_multipart_form_data() { # Check upload size in advance if (my $size = http_get("Content-Length")) { my $max_allowed = 0; - foreach my $a (values %$arg_table) { + foreach my $a (values %$main_arg_table) { $max_allowed += $a->{"maxsize"} || 65536; } if ($size > $max_allowed) { @@ -343,13 +376,13 @@ sub parse_multipart_form_data() { ($cdisp = $h->{"content-disposition"}) && $cdisp =~ /^form-data/ && (($field) = ($cdisp =~ /;name=([^;]+)/)) && - ($a = $arg_table->{"$field"})) { + ($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 $a->{"var"}) { while (defined (my $l = get_mp_line(1))) { print STDERR "VALUE $l\n" if $debug; - parse_arg_string("$field=$l"); + parse_raw_args_ll($field, $l); } next PART; } elsif (defined $a->{"file"}) { @@ -380,37 +413,43 @@ sub parse_multipart_form_data() { ### Generating Self-ref URL's ### -sub make_out_args($) { - my ($overrides) = @_; +sub make_out_args(@) { # Usage: make_out_args([arg_table, ...] name => value, ...) + my @arg_tables = ( $main_arg_table ); + while (@_ && ref($_[0]) eq 'HASH') { + push @arg_tables, shift @_; + } + my %overrides = @_; my $out = {}; - foreach my $name (keys %$arg_table) { - my $arg = $arg_table->{$name}; - defined($arg->{'var'}) || next; - defined($arg->{'pass'}) && !$arg->{'pass'} && !exists $overrides->{$name} && next; - my $value; - if (!defined($value = $overrides->{$name})) { - if (exists $overrides->{$name}) { - $value = $arg->{'default'}; - } else { - $value = ${$arg->{'var'}}; + for my $table (@arg_tables) { + for my $name (keys %$table) { + 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'}) { + $out->{$name} = $value; } - } - if ($value ne $arg->{'default'}) { - $out->{$name} = $value; } } return $out; } sub self_ref(@) { - my %h = @_; - my $out = make_out_args(\%h); + my $out = make_out_args(@_); return "?" . join(':', map { "$_=" . url_param_escape($out->{$_}) } sort keys %$out); } sub self_form(@) { - my %h = @_; - my $out = make_out_args(\%h); + my $out = make_out_args(@_); return join('', map { "\n" } sort keys %$out); }