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
$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.
$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 {
$ENV{CATALYST_SERVER} ||= "http://localhost:$PORT";
}
-use Test::More tests => 6;
+use Test::More tests => 8;
use Test::Exception;
BEGIN {
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 {