diff options
Diffstat (limited to 'lib/TUWF/Request.pm')
-rw-r--r-- | lib/TUWF/Request.pm | 28 |
1 files changed, 18 insertions, 10 deletions
diff --git a/lib/TUWF/Request.pm b/lib/TUWF/Request.pm index f7d67b4..5b3852b 100644 --- a/lib/TUWF/Request.pm +++ b/lib/TUWF/Request.pm @@ -63,6 +63,14 @@ sub reqInit { } +sub _check_control { + # Disallow any control codes, except for x09 (tab), x0a (newline) and x0d (carriage return) + # The error message is a hack to trigger the 'utf8' error code. + die "Illegal control code (does not map to Unicode)" if $_[0] =~ /[\x00-\x08\x0b\x0c\x0e-\x1f]/; + $_[0] +} + + sub _parse_urlencoded { my %dat; my $d = shift; @@ -77,9 +85,7 @@ sub _parse_urlencoded { decode_utf8($s, 1); #eg; s/%u([0-9a-fA-F]{4})/chr hex($1)/eg; - # Disallow any control codes, except for x09 (tab), x0a (newline) and x0d (carriage return) - # The error message is a hack to trigger the 'utf8' error code. - die "Illegal control code (does not map to Unicode)" if /[\x00-\x08\x0b\x0c\x0e-\x1f]/; + _check_control($_); } push @{$dat{$key}}, $val; } @@ -139,11 +145,11 @@ sub _parse_multipart { # regular form element. The standards do not require the filename to be # present, but I am not aware of any browser that does not send it. if($filename) { - push @{$nfo->{POST}{$name}}, decode_utf8 $filename, 1; - push @{$nfo->{MIMES}{$name}}, decode_utf8 $mime, 1; + push @{$nfo->{POST}{$name}}, _check_control decode_utf8 $filename, 1; + push @{$nfo->{MIMES}{$name}}, _check_control decode_utf8 $mime, 1; push @{$nfo->{FILES}{$name}}, $value; # not decoded, can be binary } else { - push @{$nfo->{POST}{$name}}, decode_utf8 $value, 1; + push @{$nfo->{POST}{$name}}, _check_control decode_utf8 $value, 1; } } } @@ -164,6 +170,8 @@ sub _parse_cookies { next if !$_ || !m{^([^\(\)<>@,;:\\"/\[\]\?=\{\}\t\s]+)=("?)(.*)\2$}; my($n, $v) = ($1, $3); next if $self->{_TUWF}{cookie_prefix} && !($n =~ s/^\Q$self->{_TUWF}{cookie_prefix}\E//); + _check_control $n; + _check_control $v; $dat{$n} = $v if !exists $dat{$n}; } return \%dat; @@ -259,13 +267,13 @@ sub reqHeader { my($self, $name) = @_; if(@_ == 2) { (my $v = uc $_[1]) =~ tr/-/_/; - return $ENV{"HTTP_$v"}||''; + return _check_control decode_utf8 $ENV{"HTTP_$v"}||'', 1; } else { return (map { if(/^HTTP_/) { (my $h = lc $_) =~ s/_([a-z])/-\U$1/g; $h =~ s/^http-//; - decode_utf8 $h, 1; + _check_control decode_utf8 $h, 1; } else { () } } sort keys %ENV); } @@ -275,7 +283,7 @@ sub reqHeader { # returns the path part of the current URI, including the leading slash sub reqPath { (my $u = ($ENV{REQUEST_URI}||'')) =~ s{\?.*$}{}; - return decode_utf8 $u, 1; + return _check_control decode_utf8 $u, 1; } @@ -293,7 +301,7 @@ sub reqBaseURI { sub reqQuery { my $u = $ENV{QUERY_STRING} ? '?'.$ENV{QUERY_STRING} : ''; - return decode_utf8 $u, 1; + return _check_control decode_utf8 $u, 1; } |