use Carp qw/croak/;
require Catalyst::Test; # Do not call import
+use Class::Load qw(load_class is_class_loaded);
use Encode qw();
use HTML::Entities;
use Test::WWW::Mechanize;
extends 'Test::WWW::Mechanize', 'Moose::Object';
-#use namespace::clean -execept => 'meta';
+#use namespace::clean -except => 'meta';
-our $VERSION = '0.53';
+our $VERSION = '0.58';
our $APP_CLASS;
my $Test = Test::Builder->new();
unless ($ENV{CATALYST_SERVER}) {
croak "catalyst_app attribute is required unless CATALYST_SERVER env variable is set"
unless $self->has_catalyst_app;
- Class::MOP::load_class($self->catalyst_app)
- unless (Class::MOP::is_class_loaded($self->catalyst_app));
+ load_class($self->catalyst_app)
+ unless (is_class_loaded($self->catalyst_app));
}
}
sub _make_request {
- my ( $self, $request ) = @_;
+ my ( $self, $request, $arg, $size, $previous) = @_;
my $response = $self->_do_catalyst_request($request);
$response->header( 'Content-Base', $response->request->uri )
$response->content_type('');
}
+ # NOTE: cargo-culted redirect checking from LWP::UserAgent:
+ $response->previous($previous) if $previous;
+ my $redirects = defined $response->redirects ? $response->redirects : 0;
+ if ($redirects > 0 and $redirects >= $self->max_redirect) {
+ return $self->_redirect_loop_detected($response);
+ }
+
# check if that was a redirect
if ( $response->header('Location')
&& $response->is_redirect
&& $self->redirect_ok( $request, $response ) )
{
+ return $self->_redirect_loop_detected($response) if $self->max_redirect <= 0;
- # remember the old response
- my $old_response = $response;
+ # TODO: this should probably create the request by cloning the original
+ # request and modifying it as LWP::UserAgent::request does. But for now...
# *where* do they want us to redirect to?
- my $location = $old_response->header('Location');
+ my $location = $response->header('Location');
# no-one *should* be returning non-absolute URLs, but if they
# are then we'd better cope with it. Let's create a new URI, using
# our request as the base.
my $uri = URI->new_abs( $location, $request->uri )->as_string;
-
- # make a new response, and save the old response in it
- $response = $self->_make_request( HTTP::Request->new( GET => $uri ) );
- my $end_of_chain = $response;
- while ( $end_of_chain->previous ) # keep going till the end
- {
- $end_of_chain = $end_of_chain->previous;
- } # of the chain...
- $end_of_chain->previous($old_response); # ...and add us to it
+ my $referral = HTTP::Request->new( GET => $uri );
+ return $self->request( $referral, $arg, $size, $response );
} else {
$response->{_raw_content} = $response->content;
}
return $response;
}
+sub _redirect_loop_detected {
+ my ( $self, $response ) = @_;
+ $response->header("Client-Warning" =>
+ "Redirect loop detected (max_redirect = " . $self->max_redirect . ")");
+ $response->{_raw_content} = $response->content;
+ return $response;
+}
+
+sub _set_host_header {
+ my ( $self, $request ) = @_;
+ # If there's no Host header, set one.
+ unless ($request->header('Host')) {
+ my $host = $self->has_host
+ ? $self->host
+ : $request->uri->host;
+ $host .= ':'.$request->uri->_port if $request->uri->_port;
+ $request->header('Host', $host);
+ }
+}
+
sub _do_catalyst_request {
my ($self, $request) = @_;
return $self->_do_remote_request($request)
if $ENV{CATALYST_SERVER};
- # If there's no Host header, set one.
- unless ($request->header('Host')) {
- my $host = $self->has_host
- ? $self->host
- : $uri->host;
+ $self->_set_host_header($request);
- $request->header('Host', $host);
- }
-
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;
- my $response =Catalyst::Test::local_request($self->{catalyst_app}, $request);
+ require Catalyst;
+ my $response = $Catalyst::VERSION >= 5.89000 ?
+ Catalyst::Test::_local_request($self->{catalyst_app}, $request) :
+ Catalyst::Test::local_request($self->{catalyst_app}, $request);
+
- # LWP would normally do this, but we dont get down that far.
+ # LWP would normally do this, but we don't 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.
+ # If there's no host then definitley not an external request.
$request->uri->can('host_port') or return;
if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) {
$request->uri->host( $server->host );
$request->uri->port( $server->port );
$request->uri->path( $server->path . $request->uri->path );
+ $self->_set_host_header($request);
return $self->SUPER::_make_request($request);
}
my ($class, $app) = @_;
if (defined $app) {
- Class::MOP::load_class($app)
- unless (Class::MOP::is_class_loaded($app));
+ load_class($app)
+ unless (is_class_loaded($app));
$APP_CLASS = $app;
}
=head1 AUTHOR
-Ash Berlin C<< <ash@cpan.org> >> (current maintiner)
+Ash Berlin C<< <ash@cpan.org> >> (current maintainer)
Original Author: Leon Brocard, C<< <acme@astray.com> >>