From: Matt S Trout <mst@shadowcat.co.uk>
Date: Thu, 6 Oct 2011 21:15:52 +0000 (+0000)
Subject: maintain $env->{Web::Dispatch.original_env} for ParamParser to cache in
X-Git-Tag: v0.010~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FWeb-Simple.git;a=commitdiff_plain;h=d96756e81118d31b2e23987ae909aafd7e87269e

maintain $env->{Web::Dispatch.original_env} for ParamParser to cache in
---

diff --git a/Changes b/Changes
index e8cc134..35d084e 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
 Change log for Web::Simple
 
+  - Preserve original env in Web::Dispatch so ParamParser can cache in there
+    (stops HTTP::Body object getting destroyed early thereby losing uploads)
+
 0.009 - 2011-10-03
   - Complete port from HTTP::Request::AsCGI to Plack::Test
   - Add experimental upload support
diff --git a/lib/Web/Dispatch.pm b/lib/Web/Dispatch.pm
index 46961c2..c6dcded 100644
--- a/lib/Web/Dispatch.pm
+++ b/lib/Web/Dispatch.pm
@@ -37,7 +37,7 @@ sub _dispatch {
 
     return $try if ref($try) eq 'ARRAY';
     if (ref($try) eq 'HASH') {
-      $env = { %$env, %$try };
+      $env = { 'Web::Dispatch.original_env' => $env, %$env, %$try };
       next;
     }
 
diff --git a/lib/Web/Dispatch/ParamParser.pm b/lib/Web/Dispatch/ParamParser.pm
index 90c62b1..e8ed581 100644
--- a/lib/Web/Dispatch/ParamParser.pm
+++ b/lib/Web/Dispatch/ParamParser.pm
@@ -7,15 +7,16 @@ sub UNPACKED_QUERY () { __PACKAGE__.'.unpacked_query' }
 sub UNPACKED_BODY () { __PACKAGE__.'.unpacked_body' }
 sub UNPACKED_BODY_OBJECT () { __PACKAGE__.'.unpacked_body_object' }
 sub UNPACKED_UPLOADS () { __PACKAGE__.'.unpacked_uploads' }
+sub ORIG_ENV () { 'Web::Dispatch.original_env' }
 
 sub get_unpacked_query_from {
-  return $_[0]->{+UNPACKED_QUERY} ||= do {
+  return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_QUERY} ||= do {
     _unpack_params($_[0]->{QUERY_STRING})
   };
 }
 
 sub get_unpacked_body_from {
-  return $_[0]->{+UNPACKED_BODY} ||= do {
+  return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_BODY} ||= do {
     my $ct = lc($_[0]->{CONTENT_TYPE}||'');
     if (!$_[0]->{CONTENT_LENGTH}) {
       {}
@@ -39,7 +40,7 @@ sub get_unpacked_body_from {
 
 sub get_unpacked_body_object_from {
   # we may have no object at all - so use a single element arrayref for ||=
-  return ($_[0]->{+UNPACKED_BODY_OBJECT} ||= do {
+  return (($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_BODY_OBJECT} ||= do {
     if (!$_[0]->{CONTENT_LENGTH}) {
       [ undef ]
     } elsif (index(lc($_[0]->{CONTENT_TYPE}||''),'multipart/form-data')==-1) {
diff --git a/lib/Web/Dispatch/Predicates.pm b/lib/Web/Dispatch/Predicates.pm
index db2ad88..dae4a80 100644
--- a/lib/Web/Dispatch/Predicates.pm
+++ b/lib/Web/Dispatch/Predicates.pm
@@ -12,7 +12,7 @@ sub match_and {
   my @match = @_;
   sub {
     my ($env) = @_;
-    my $my_env = { %$env };
+    my $my_env = { 'Web::Dispatch.original_env' => $env, %$env };
     my $new_env;
     my @got;
     foreach my $match (@match) {
diff --git a/lib/Web/Simple/Application.pm b/lib/Web/Simple/Application.pm
index e4ef3db..88f025e 100644
--- a/lib/Web/Simple/Application.pm
+++ b/lib/Web/Simple/Application.pm
@@ -89,7 +89,7 @@ sub _test_request_spec_to_http_request {
 
   my $request = HTTP::Request->new($method => $path);
 
-  if ($method eq 'POST' or $method eq 'PUT' and @rest) {
+  if (($method eq 'POST' or $method eq 'PUT') and @rest) {
     my $content = do {
       require URI;
       my $url = URI->new('http:');
diff --git a/t/sub-dispatch-args.t b/t/sub-dispatch-args.t
index a5f3fa4..71fc4eb 100644
--- a/t/sub-dispatch-args.t
+++ b/t/sub-dispatch-args.t
@@ -34,6 +34,7 @@ use Plack::Test;
     sub show_landing {
         my ($self, @args) = @_;
         local $self->{_dispatcher};
+        local $args[-1]->{'Web::Dispatch.original_env'};
         return [
             200, ['Content-Type' => 'application/perl' ],
             [::Dumper \@args],
@@ -42,6 +43,7 @@ use Plack::Test;
     sub show_users {
         my ($self, @args) = @_;
         local $self->{_dispatcher};
+        local $args[-1]->{'Web::Dispatch.original_env'};
         return [
             200, ['Content-Type' => 'application/perl' ],
             [::Dumper \@args],
@@ -50,6 +52,7 @@ use Plack::Test;
     sub show_user {
         my ($self, @args) = @_;
         local $self->{_dispatcher};
+        local $args[-1]->{'Web::Dispatch.original_env'};
         return [
             200, ['Content-Type' => 'application/perl' ],
             [::Dumper \@args],
@@ -58,6 +61,7 @@ use Plack::Test;
     sub process_post {
         my ($self, @args) = @_;
         local $self->{_dispatcher};
+        local $args[-1]->{'Web::Dispatch.original_env'};
         return [
             200, ['Content-Type' => 'application/perl' ],
             [::Dumper \@args],