TUWF::Request: Check for control characters on all client input

Seems much safer. I've not tested this patch as well as I'd like, I'll
do some more testing later to see if I broke something.

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;
 }