changed the way test dumping a request works

[catagits/Catalyst-Runtime.git] / lib / Catalyst / Request.pm

diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm
index 17f0be9..de9f15f 100644 (file)
--- a/lib/Catalyst/Request.pm
+++ b/lib/Catalyst/Request.pm
@@ -14,7 +14,7 @@ use namespace::clean -except => 'meta';
 
 with 'MooseX::Emulate::Class::Accessor::Fast';
 
-has env => (is => 'ro', writer => '_set_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
@@ -92,17 +92,38 @@ has _log => (
 );
 
 has io_fh => (
-  is=>'ro',
-  predicate=>'has_io_fh',
-  lazy=>1,
-  builder=>'_build_io_fh');
+    is=>'ro',
+    predicate=>'has_io_fh',
+    lazy=>1,
+    builder=>'_build_io_fh');
 
-  sub _build_io_fh {
+sub _build_io_fh {
     my $self = shift;
     return $self->env->{'psgix.io'}
       || die "Your Server does not support psgix.io";
-  };
+};
+
+has data_handlers => ( is=>'ro', isa=>'HashRef', default=>sub { +{} } );
+
+has body_data => (
+    is=>'ro',
+    lazy=>1,
+    builder=>'_build_body_data');
 
+sub _build_body_data {
+    my ($self) = @_;
+    my $content_type = $self->content_type;
+    my ($match) = grep { $content_type =~/$_/i }
+      keys(%{$self->data_handlers});
+
+    if($match) {
+      my $fh = $self->body;
+      local $_ = $fh;
+      return $self->data_handlers->{$match}->($fh, $self);
+    } else { 
+      return undef;
+    }
+}
 
 # Amount of data to read from input on each pass
 our $CHUNKSIZE = 64 * 1024;
@@ -172,8 +193,6 @@ sub prepare_parameters {
     return $self->parameters;
 }
 
-
-
 sub _build_parameters {
     my ( $self ) = @_;
     my $parameters = {};
@@ -205,6 +224,18 @@ has _uploadtmp => (
 sub prepare_body {
     my ( $self ) = @_;
 
+    #warn "XXX ${\$self->_uploadtmp}" if $self->_has_uploadtmp;
+
+    if(my $plack_body = $self->env->{'plack.request.http.body'}) {
+      warn "wtF" x 100;
+        $self->_body($plack_body);
+        $self->_body->cleanup(1); # Make extra sure!
+        $self->_body->tmpdir( $self->_uploadtmp )
+          if $self->_has_uploadtmp;
+    } else {
+
+    }
+
     if ( my $length = $self->_read_length ) {
         unless ( $self->_body ) {
             my $type = $self->header('Content-Type');
@@ -232,6 +263,59 @@ sub prepare_body {
     }
 }
 
+sub prepare_bodyXXX {
+    my ( $self ) = @_;
+    if(my $plack_body = $self->env->{'plack.request.http.body'}) {
+    
+
+    } else {
+
+    }
+
+    die "XXX ${\$self->_uploadtmp}" x1000; $self->_has_uploadtmp;
+
+    if ( my $length = $self->_read_length ) {
+        unless ( $self->_body ) {
+            
+            ## If something plack middle already ready the body, just use
+            ## that.
+
+            my $body;
+            if(my $plack_body = $self->env->{'plack.request.http.body'}) {
+                $body = $plack_body;
+            } else {
+                my $type = $self->header('Content-Type');
+                $body = HTTP::Body->new($type, $length);
+
+                ## Play nice with Plak Middleware that looks for a body
+                $self->env->{'plack.request.http.body'} = $body;
+                $self->_body($body);
+
+                $body->cleanup(1); # Make extra sure!
+                $body->tmpdir( $self->_uploadtmp )
+                  if $self->_has_uploadtmp;
+            }
+        }
+
+        # Check for definedness as you could read '0'
+        while ( defined ( my $buffer = $self->read() ) ) {
+            $self->prepare_body_chunk($buffer);
+        }
+
+        # paranoia against wrong Content-Length header
+        my $remaining = $length - $self->_read_position;
+        if ( $remaining > 0 ) {
+            Catalyst::Exception->throw(
+                "Wrong Content-Length value: $length" );
+        }
+    }
+    else {
+        # Defined but will cause all body code to be skipped
+        $self->_body(0);
+    }
+}
+
+
 sub prepare_body_chunk {
     my ( $self, $chunk ) = @_;
 
@@ -294,7 +378,7 @@ has _body => (
 #             and provide a custom reader..
 sub body {
   my $self = shift;
-  $self->prepare_body unless ! $self->_has_body;
+  $self->prepare_body unless $self->_has_body;
   croak 'body is a reader' if scalar @_;
   return blessed $self->_body ? $self->_body->body : $self->_body;
 }
@@ -332,6 +416,7 @@ Catalyst::Request - provides information about the current client request
     $req->args;
     $req->base;
     $req->body;
+    $req->body_data;
     $req->body_parameters;
     $req->content_encoding;
     $req->content_length;
@@ -414,6 +499,14 @@ Returns the message body of the request, as returned by L<HTTP::Body>: a string,
 unless Content-Type is C<application/x-www-form-urlencoded>, C<text/xml>, or
 C<multipart/form-data>, in which case a L<File::Temp> object is returned.
 
+=head2 $req->body_data
+
+Returns a Perl representation of POST/PUT body data that is not classic HTML
+form data, such as JSON, XML, etc.  By default, Catalyst will parse incoming
+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.
+
 =head2 $req->body_parameters
 
 Returns a reference to a hash containing body (POST) parameters. Values can