[Catalyst-commits] r9503 - in Test-WWW-Mechanize-Catalyst/trunk: .
lib/Test/WWW/Mechanize t t/lib
ash at dev.catalyst.perl.org
ash at dev.catalyst.perl.org
Mon Mar 16 10:02:45 GMT 2009
Author: ash
Date: 2009-03-16 10:02:44 +0000 (Mon, 16 Mar 2009)
New Revision: 9503
Modified:
Test-WWW-Mechanize-Catalyst/trunk/CHANGES
Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm
Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm
Test-WWW-Mechanize-Catalyst/trunk/t/multi_content_type.t
Log:
Dont use Catalyst::Test for handling remote apps (CATALYST_SERVER)
Modified: Test-WWW-Mechanize-Catalyst/trunk/CHANGES
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/CHANGES 2009-03-14 23:19:18 UTC (rev 9502)
+++ Test-WWW-Mechanize-Catalyst/trunk/CHANGES 2009-03-16 10:02:44 UTC (rev 9503)
@@ -3,6 +3,8 @@
- Doc updates from Jester
- User agent fixes from ANDREMAR
- Fix bug where redirect was followed on a 500 response
+ - All remote requests (i.e. CATALYST_SERVER env var) now use our own
+ mechanize object, rather than an unconfigurable one from Catalyst:Test
0.50 Tue Feb 17 09:12 GMT 2009
- Remove warning in HTTP::Cookies
Modified: Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm 2009-03-14 23:19:18 UTC (rev 9502)
+++ Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm 2009-03-16 10:02:44 UTC (rev 9503)
@@ -75,12 +75,9 @@
my ( $self, $request ) = @_;
my $response = $self->_do_catalyst_request($request);
- $response->header( 'Content-Base', $request->uri );
- $response->request($request);
- if ( $request->uri->as_string =~ m{^/} ) {
- $request->uri(
- URI->new( 'http://localhost:80/' . $request->uri->as_string ) );
- }
+ $response->header( 'Content-Base', $response->request->uri )
+ unless $response->header('Content-Base');
+
$self->cookie_jar->extract_cookies($response) if $self->cookie_jar;
# fail tests under the Catalyst debug screen
@@ -140,7 +137,7 @@
$self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
# Woe betide anyone who unsets CATALYST_SERVER
- return Catalyst::Test::remote_request($request)
+ return $self->_do_remote_request($request)
if $ENV{CATALYST_SERVER};
# If there's no Host header, set one.
@@ -151,21 +148,76 @@
$request->header('Host', $host);
}
-
- if ( $self->{allow_external} ) {
- unless ( $request->uri->as_string =~ m{^/}
- || $request->uri->host eq 'localhost' )
- {
- return $self->SUPER::_make_request($request);
- }
- }
-
+
+ my $res = $self->_check_external_request($request);
+ return $res if $res;
+
my @creds = $self->get_basic_credentials( "Basic", $uri );
$request->authorization_basic( @creds ) if @creds;
- return Catalyst::Test::local_request($self->{catalyst_app}, $request);
+ my $response =Catalyst::Test::local_request($self->{catalyst_app}, $request);
+
+ # LWP would normally do this, but we dont get down that far.
+ $response->request($request);
+
+ return $response
}
+sub _check_external_request {
+ my ($self, $request) = @_;
+
+ # If there's no host then definatley not an external request.
+ $request->uri->can('host_port') or return;
+
+ if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) {
+ return $self->SUPER::_make_request($request);
+ }
+ return undef;
+}
+
+sub _do_remote_request {
+ my ($self, $request) = @_;
+
+ my $res = $self->_check_external_request($request);
+ return $res if $res;
+
+ my $server = URI->new( $ENV{CATALYST_SERVER} );
+
+ 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 );
+ return $self->SUPER::_make_request($request);
+}
+
sub import {
my ($class, $app) = @_;
Modified: Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm 2009-03-14 23:19:18 UTC (rev 9502)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm 2009-03-16 10:02:44 UTC (rev 9503)
@@ -13,6 +13,14 @@
$c->response->output( html( 'Root', 'Hello, test ☺!' ) );
}
+# redirect to a redirect
+sub hello: Global {
+ my ( $self, $context ) = @_;
+ my $where = $context->uri_for('/');
+ $context->response->redirect($where);
+ return;
+}
+
sub html {
my ( $title, $body ) = @_;
return qq[
Modified: Test-WWW-Mechanize-Catalyst/trunk/t/multi_content_type.t
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/multi_content_type.t 2009-03-14 23:19:18 UTC (rev 9502)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/multi_content_type.t 2009-03-16 10:02:44 UTC (rev 9503)
@@ -10,7 +10,7 @@
$ENV{CATALYST_SERVER} ||= "http://localhost:$PORT";
}
-use Test::More tests => 6;
+use Test::More tests => 8;
use Test::Exception;
BEGIN {
@@ -36,19 +36,23 @@
TRY_CONNECT: {
eval { $m->get('/') };
- if ($@ || $m->content =~ /Can't connect to localhost:$PORT/) {
+ if ($@ || $m->content =~ /Can't connect to \w+:$PORT/) {
$skip = $@ || $m->content;
}
}
SKIP: {
- skip $skip, 5 if $skip;
+ skip $skip, 7 if $skip;
lives_ok { $m->get_ok( '/', 'Get a multi Content-Type response' ) }
'Survive to a multi Content-Type sting';
is( $m->ct, 'text/html', 'Multi Content-Type Content-Type' );
$m->title_is( 'Root', 'Multi Content-Type title' );
$m->content_contains( "Hello, test \x{263A}!", 'Multi Content-Type body' );
+
+ # Test a redirect with a remote server now too.
+ $m->get_ok( '/hello' );
+ is($m->uri, "$ENV{CATALYST_SERVER}/");
}
END {
More information about the Catalyst-commits
mailing list