X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FRequest.pm;h=56dfb65cd82dce2be27823644a34d72053e83b61;hb=f384c84887409fd343be4751b40a232ebf224b5c;hp=b131d4c7b1fedd549157ace33970893d5cec8d71;hpb=c2fef52fe310a9111756a2878500c6b11e7dbefb;p=catagits%2FCatalyst-Runtime.git

diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm
index b131d4c..56dfb65 100644
--- a/lib/Catalyst/Request.pm
+++ b/lib/Catalyst/Request.pm
@@ -17,7 +17,7 @@ use namespace::clean -except => 'meta';
 
 with 'MooseX::Emulate::Class::Accessor::Fast';
 
-has env => (is => 'ro', writer => '_set_env', predicate => 'has_env');
+has env => (is => 'ro', writer => '_set_env', predicate => '_has_env');
 # XXX Deprecated crap here - warn?
 has action => (is => 'rw');
 # XXX: Deprecated in docs ages ago (2006), deprecated with warning in 5.8000 due
@@ -243,7 +243,7 @@ sub prepare_body {
     # If previously applied middleware created the HTTP::Body object, then we
     # just use that one.  
 
-    if(my $plack_body = $self->env->{'plack.request.http.body'}) {
+    if(my $plack_body = $self->_has_env ? $self->env->{'plack.request.http.body'} : undef) {
         $self->_body($plack_body);
         $self->_body->cleanup(1);
         return;
@@ -439,6 +439,7 @@ Catalyst::Request - provides information about the current client request
     $req->uri;
     $req->user;
     $req->user_agent;
+    $req->env;
 
 See also L<Catalyst>, L<Catalyst::Request::Upload>.
 
@@ -635,6 +636,56 @@ If multiple C<baz> parameters are provided this code might corrupt data or
 cause a hash initialization error. For a more straightforward interface see
 C<< $c->req->parameters >>.
 
+B<NOTE> Interfaces like this, which are based on L<CGI> and the C<param> method
+are now known to cause demonstrated exploits. It is highly recommended that you
+avoid using this method, and migrate existing code away from it.  Here's the
+whitepaper of the exploit:
+
+L<http://blog.gerv.net/2014/10/new-class-of-vulnerability-in-perl-web-applications/>
+
+Basically this is an exploit that takes advantage of how L<\param> will do one thing
+in scalar context and another thing in list context.  This is combined with how Perl
+chooses to deal with duplicate keys in a hash definition by overwriting the value of
+existing keys with a new value if the same key shows up again.  Generally you will be
+vulnerale to this exploit if you are using this method in a direct assignment in a
+hash, such as with a L<DBIx::Class> create statement.  For example, if you have
+parameters like:
+
+    user?user=123&foo=a&foo=user&foo=456
+
+You could end up with extra parameters injected into your method calls:
+
+    $c->model('User')->create({
+      user => $c->req->param('user'),
+      foo => $c->req->param('foo'),
+    });
+
+Which would look like:
+
+    $c->model('User')->create({
+      user => 123,
+      foo => qw(a user 456),
+    });
+
+(or to be absolutely clear if you are not seeing it):
+
+    $c->model('User')->create({
+      user => 456,
+      foo => 'a',
+    });
+
+Possible remediations include scrubbing your parameters with a form validator like
+L<HTML::FormHandler> or being careful to force scalar context using the scalar
+keyword:
+
+    $c->model('User')->create({
+      user => scalar($c->req->param('user')),
+      foo => scalar($c->req->param('foo')),
+    });
+
+Upcoming versions of L<Catalyst> will disable this interface by default and require
+you to positively enable it should you require it for backwards compatibility reasons.
+
 =cut
 
 sub param {
@@ -644,9 +695,15 @@ sub param {
         return keys %{ $self->parameters };
     }
 
-    if ( @_ == 1 ) {
+    # If anything in @_ is undef, carp about that, and remove it from
+    # the list;
+    
+    my @params = grep { defined($_) ? 1 : do {carp "You called ->params with an undefined value"; 0} } @_;
 
-        my $param = shift;
+    if ( @params == 1 ) {
+
+        defined(my $param = shift @params) ||
+          carp "You called ->params with an undefined value 2";
 
         unless ( exists $self->parameters->{$param} ) {
             return wantarray ? () : undef;
@@ -663,9 +720,9 @@ sub param {
               : $self->parameters->{$param};
         }
     }
-    elsif ( @_ > 1 ) {
-        my $field = shift;
-        $self->parameters->{$field} = [@_];
+    elsif ( @params > 1 ) {
+        my $field = shift @params;
+        $self->parameters->{$field} = [@params];
     }
 }
 
@@ -989,6 +1046,9 @@ combined from those in the request and those in the body.
 
 If parameters have already been set will clear the parameters and build them again.
 
+=head2 $self->env
+
+Access to the raw PSGI env.  
 
 =head2 meta