From: Ash Berlin Date: Mon, 16 Mar 2009 10:02:44 +0000 (+0000) Subject: Dont use Catalyst::Test for handling remote apps (CATALYST_SERVER) X-Git-Tag: 0.51~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FTest-WWW-Mechanize-Catalyst.git;a=commitdiff_plain;h=97ae89ab316de422a55b3b3252ab4dbabfcdbdcd Dont use Catalyst::Test for handling remote apps (CATALYST_SERVER) --- diff --git a/CHANGES b/CHANGES index dde5d7c..619afe8 100644 --- a/CHANGES +++ b/CHANGES @@ -3,6 +3,8 @@ Revision history for Perl module Test::WWW::Mechanize::Catalyst: - 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 diff --git a/lib/Test/WWW/Mechanize/Catalyst.pm b/lib/Test/WWW/Mechanize/Catalyst.pm index 8910c44..358f33f 100644 --- a/lib/Test/WWW/Mechanize/Catalyst.pm +++ b/lib/Test/WWW/Mechanize/Catalyst.pm @@ -75,12 +75,9 @@ sub _make_request { 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 @@ sub _do_catalyst_request { $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,19 +148,74 @@ sub _do_catalyst_request { $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 { diff --git a/t/lib/ExternalCatty.pm b/t/lib/ExternalCatty.pm index da573f2..7b754ae 100644 --- a/t/lib/ExternalCatty.pm +++ b/t/lib/ExternalCatty.pm @@ -13,6 +13,14 @@ sub default : Private { $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[ diff --git a/t/multi_content_type.t b/t/multi_content_type.t index 71ac228..521f463 100644 --- a/t/multi_content_type.t +++ b/t/multi_content_type.t @@ -10,7 +10,7 @@ BEGIN { $ENV{CATALYST_SERVER} ||= "http://localhost:$PORT"; } -use Test::More tests => 6; +use Test::More tests => 8; use Test::Exception; BEGIN { @@ -36,19 +36,23 @@ my $skip = 0; 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 {