X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FRequest.pm;h=671dd51e4368360260818c7a7add45624329ef27;hp=09fb8d5f4d4fb4575ef0ad36b383c8f29568e833;hb=b94f8e72c1c8e8348efc0eb96660dd977a838ea7;hpb=9d8d0ab94e468c7399f6efdff4735d8b3a54307a

diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm
index 09fb8d5..671dd51 100644
--- a/lib/Catalyst/Request.pm
+++ b/lib/Catalyst/Request.pm
@@ -10,7 +10,7 @@ use HTTP::Headers;
 use Stream::Buffered;
 use Hash::MultiValue;
 use Scalar::Util;
-
+use Catalyst::Exception;
 use Moose;
 
 use namespace::clean -except => 'meta';
@@ -118,7 +118,11 @@ has body_data => (
 
 sub _build_body_data {
     my ($self) = @_;
-    my $content_type = $self->content_type;
+
+    # Not sure if these returns should not be exceptions...
+    my $content_type = $self->content_type || return;
+    return unless ($self->method eq 'POST' || $self->method eq 'PUT');
+
     my ($match) = grep { $content_type =~/$_/i }
       keys(%{$self->data_handlers});
 
@@ -127,7 +131,7 @@ sub _build_body_data {
       local $_ = $fh;
       return $self->data_handlers->{$match}->($fh, $self);
     } else { 
-      return undef;
+      Catalyst::Exception->throw("$content_type is does not have an available data handler");
     }
 }
 
@@ -502,6 +506,13 @@ data of the type 'application/json' and return access to that data via this
 method.  You may define addition data_handlers via a global configuration
 setting.  See L<Catalyst\DATA HANDLERS> for more information.
 
+If the POST is malformed in some way (such as undefined or not content that
+matches the content-type) we raise a L<Catalyst::Exception> with the error
+text as the message.
+
+If the POSTed content type does not match an availabled data handler, this
+will also raise an exception.
+
 =head2 $req->body_parameters
 
 Returns a reference to a hash containing body (POST) parameters. Values can
@@ -636,6 +647,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 {
@@ -645,9 +706,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} } @_;
+
+    if ( @params == 1 ) {
 
-        my $param = shift;
+        defined(my $param = shift @params) ||
+          carp "You called ->params with an undefined value 2";
 
         unless ( exists $self->parameters->{$param} ) {
             return wantarray ? () : undef;
@@ -664,9 +731,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];
     }
 }