X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FTest.pm;h=5c0cbe7cfd9ea22e2a20c1b14d10d7b69367a0ee;hb=7ebac5f89810aab16ec76fc28dea45e936172a67;hp=9f109052c584e5b430a2950f87304606b100df9d;hpb=c41956b0b05a9062149d05801f76b26c2db77c5b;p=catagits%2FCatalyst-Runtime.git

diff --git a/lib/Catalyst/Test.pm b/lib/Catalyst/Test.pm
index 9f10905..5c0cbe7 100644
--- a/lib/Catalyst/Test.pm
+++ b/lib/Catalyst/Test.pm
@@ -110,15 +110,21 @@ my $build_exports = sub {
         },
         action_ok => sub {
             my $action = shift;
-            return Test::More->builder->ok($request->($action)->is_success, @_);
+            my $meth = $request->($action)->request->method;
+            my @args = @_ ? @_ : ("$meth $action returns successfully");
+            return Test::More->builder->ok($request->($action)->is_success,@args);
         },
         action_redirect => sub {
             my $action = shift;
-            return Test::More->builder->ok($request->($action)->is_redirect,@_);
+            my $meth = $request->($action)->request->method;
+            my @args = @_ ? @_ : ("$meth $action returns a redirect");
+            return Test::More->builder->ok($request->($action)->is_redirect,@args);
         },
         action_notfound => sub {
             my $action = shift;
-            return Test::More->builder->is_eq($request->($action)->code,404,@_);
+            my $meth = $request->($action)->request->method;
+            my @args = @_ ? @_ : ("$meth $action returns a 404");
+            return Test::More->builder->is_eq($request->($action)->code,404,@args);
         },
         contenttype_is => sub {
             my $action = shift;
@@ -256,22 +262,36 @@ C<$c>. Note that this only works for local requests.
 
 =cut
 
-sub _local_request {
-    my $class = shift;
-
-    my $app = ref($class) eq "CODE" ? $class : $class->_finalized_psgi_app;
+sub _request {
+    my $args = shift;
 
     my $request = Catalyst::Utils::request(shift);
+
     my %extra_env;
     _customize_request($request, \%extra_env, @_);
+    $args->{mangle_request}->($request) if $args->{mangle_request};
 
     my $ret;
     test_psgi
-        app    => sub { $app->({ %{ $_[0] }, %extra_env }) },
+        %{ $args },
+        app    => sub { $args->{app}->({ %{ $_[0] }, %extra_env }) },
         client => sub {
-            my $psgi_app = shift;
-
+            my ($psgi_app) = @_;
             my $resp = $psgi_app->($request);
+            $args->{mangle_response}->($resp) if $args->{mangle_response};
+            $ret = $resp;
+        };
+
+    return $ret;
+}
+
+sub _local_request {
+    my $class = shift;
+
+    return _request({
+        app => ref($class) eq "CODE" ? $class : $class->_finalized_psgi_app,
+        mangle_response => sub {
+            my ($resp) = @_;
 
             # HTML head parsing based on LWP::UserAgent
             #
@@ -291,58 +311,21 @@ sub _local_request {
             for my $f ( $h->header_field_names ) {
                 $resp->init_header( $f, [ $h->header($f) ] );
             }
-
-            $ret = $resp;
-        };
-
-    return $ret;
+            # Another horrible hack to make the response headers have a
+            # 'status' field. This is for back-compat, but you should
+            # call $resp->code instead!
+            $resp->init_header('status', [ $resp->code ]);
+        },
+    }, @_);
 }
 
 my $agent;
 
 sub _remote_request {
     require LWP::UserAgent;
-
-    my $request = Catalyst::Utils::request( shift(@_) );
-    my $server  = URI->new( $ENV{CATALYST_SERVER} );
-
-    _customize_request($request, @_);
-
-    if ( $server->path =~ m|^(.+)?/$| ) {
-        my $path = $1;
-        $server->path("$path") if $path;    # need to be quoted
-    }
-
-    # the request path needs to be sanitised if $server is using a
-    # non-root path due to potential overlap between request path and
-    # response path.
-    if ($server->path) {
-        # If request path is '/', we have to add a trailing slash to the
-        # final request URI
-        my $add_trailing = $request->uri->path eq '/';
-
-        my @sp = split '/', $server->path;
-        my @rp = split '/', $request->uri->path;
-        shift @sp;shift @rp; # leading /
-        if (@rp) {
-            foreach my $sp (@sp) {
-                $sp eq $rp[0] ? shift @rp : last
-            }
-        }
-        $request->uri->path(join '/', @rp);
-
-        if ( $add_trailing ) {
-            $request->uri->path( $request->uri->path . '/' );
-        }
-    }
-
-    $request->uri->scheme( $server->scheme );
-    $request->uri->host( $server->host );
-    $request->uri->port( $server->port );
-    $request->uri->path( $server->path . $request->uri->path );
+    local $Plack::Test::Impl = 'ExternalServer';
 
     unless ($agent) {
-
         $agent = LWP::UserAgent->new(
             keep_alive   => 1,
             max_redirect => 0,
@@ -356,7 +339,43 @@ sub _remote_request {
         $agent->env_proxy;
     }
 
-    return $agent->request($request);
+
+    my $server = URI->new($ENV{CATALYST_SERVER});
+    if ( $server->path =~ m|^(.+)?/$| ) {
+        my $path = $1;
+        $server->path("$path") if $path;    # need to be quoted
+    }
+
+    return _request({
+        ua             => $agent,
+        uri            => $server,
+        mangle_request => sub {
+            my ($request) = @_;
+
+            # the request path needs to be sanitised if $server is using a
+            # non-root path due to potential overlap between request path and
+            # response path.
+            if ($server->path) {
+                # If request path is '/', we have to add a trailing slash to the
+                # final request URI
+                my $add_trailing = ($request->uri->path eq '/' || $request->uri->path eq '') ? 1 : 0;
+
+                my @sp = split '/', $server->path;
+                my @rp = split '/', $request->uri->path;
+                shift @sp; shift @rp; # leading /
+                if (@rp) {
+                    foreach my $sp (@sp) {
+                        $sp eq $rp[0] ? shift @rp : last
+                    }
+                }
+                $request->uri->path(join '/', @rp);
+
+                if ( $add_trailing ) {
+                    $request->uri->path( $request->uri->path . '/' );
+                }
+            }
+        },
+    }, @_);
 }
 
 for my $name (qw(local_request remote_request)) {