docs and new test cases

diff --git a/Changes b/Changes
index 28e8d58..928442f 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,14 @@
 # This file documents the revision history for Perl extension Catalyst.
 
+5.90078 - 2014-12-30
+  - POD corrections (sergey++)
+  - New configuration option to disable the HTTP Exception passthru feature
+    introduced in 5.90060.  You can use this if that feature is causing you
+    trouble. (davewood++);
+  - Some additional helper methods for dealing with errors.
+  - More clear exception when $request->body_data tries to parse malformed POSTed
+    data.  Added documentation and tests around this.
+
 5.90077 - 2014-11-18
   - We store the PSGI $env in Catalyst::Engine for backcompat reasons.  Changed
     this so that the storage is a weak reference, so that it goes out of scope

diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm
index 32aea57..14ca58e 100644 (file)
--- a/lib/Catalyst.pm
+++ b/lib/Catalyst.pm
@@ -518,6 +518,9 @@ Add a new error.
 
     $c->error('Something bad happened');
 
+Calling this will always return an arrayref (if there are no errors it
+will be an empty arrayref.
+
 =cut
 
 sub error {
@@ -562,6 +565,29 @@ Returns true if you have errors
 
 sub has_errors { scalar(@{shift->error}) ? 1:0 }
 
+=head2 $c->last_error
+
+Returns the most recent error in the stack (the one most recently added...)
+or nothing if there are no errors.
+
+=cut
+
+sub last_error { my ($err, @errs) = @{shift->error}; return $err }
+
+=head2 shift_errors
+
+shifts the most recently added error off the error stack and returns if.  Returns
+nothing if there are nomore errors.
+
+=cut
+
+sub shift_errors {
+    my ($self) = @_;
+    my ($err, @errors) = @{$self->error};
+    $self->{error} = \@errors;
+    return $err;
+}
+
 sub _comp_search_prefixes {
     my $c = shift;
     return map $c->components->{ $_ }, $c->_comp_names_search_prefixes(@_);
@@ -3437,9 +3463,15 @@ sub default_data_handlers {
             ->can('build_cgi_struct')->($params);
       },
       'application/json' => sub {
-          Class::Load::load_first_existing_class('JSON::MaybeXS', 'JSON')
-            ->can('decode_json')->(do { local $/; $_->getline });
-      },
+          my ($fh, $req) = @_;
+          my $parser = Class::Load::load_first_existing_class('JSON::MaybeXS', 'JSON');
+          my $slurped;
+          return eval { 
+            local $/;
+            $slurped = $fh->getline;
+            $parser->can("decode_json")->($slurped);
+          } || Catalyst::Exception->throw(sprintf "Error Parsing POST '%s', Error: %s", (defined($slurped) ? $slurped : 'undef') ,$@);
+        },
     };
 }
 

diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm
index 56dfb65..671dd51 100644 (file)
--- 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

diff --git a/t/consumes.t b/t/consumes.t
new file mode 100644 (file)
index 0000000..a96d209
--- /dev/null
+++ b/t/consumes.t
@@ -0,0 +1,59 @@
+use warnings;
+use strict;
+use Test::More;
+
+# Test case for reported issue when an action consumes JSON but a
+# POST sends nothing we get a hard error
+
+{
+  package MyApp::Controller::Root;
+  $INC{'MyApp/Controller/Root.pm'} = __FILE__;
+
+  use base 'Catalyst::Controller';
+
+  sub bar :Local Args(0) POST Consumes(JSON) {
+    my( $self, $c ) = @_;
+    my $foo = $c->req->body_data;
+  }
+
+  sub end :Private {
+    my( $self, $c ) = @_;
+    my $body = $c->shift_errors;
+    $c->res->body( $body || "No errors");
+  }
+
+  package MyApp;
+  use Catalyst;
+  MyApp->setup;
+}
+
+use HTTP::Request::Common;
+use Catalyst::Test 'MyApp';
+
+{
+  # Test to send no post
+  ok my $res = request POST 'root/bar',
+    'Content-Type' => 'application/json';
+
+  like $res->content, qr"Error Parsing POST 'undef'";
+}
+
+{
+  # Test to send bad (malformed JSON) post
+  ok my $res = request POST 'root/bar',
+    'Content-Type' => 'application/json',
+    'Content' => 'i am not JSON';
+
+  like $res->content, qr/Error Parsing POST 'i am not JSON'/;
+}
+
+{
+  # Test to send bad (malformed JSON) post
+  ok my $res = request POST 'root/bar',
+    'Content-Type' => 'application/json',
+    'Content' => '{ "a":"b" }';
+
+  is $res->content, 'No errors';
+}
+
+done_testing();