X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FWWW%2FMechanize%2FCatalyst.pm;h=063d2473704ea6d15a0b50194930dc292499aeb1;hb=b2d14536bd267ad2f9141558f1e78c1e31828f77;hp=96d69a1789bd9fc31835fed53a6f231996245d80;hpb=900a563bc3667ac43aacd814e9754a7c4b4a340b;p=catagits%2FTest-WWW-Mechanize-Catalyst.git diff --git a/lib/Test/WWW/Mechanize/Catalyst.pm b/lib/Test/WWW/Mechanize/Catalyst.pm index 96d69a1..063d247 100644 --- a/lib/Test/WWW/Mechanize/Catalyst.pm +++ b/lib/Test/WWW/Mechanize/Catalyst.pm @@ -4,15 +4,16 @@ use Moose; 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.60'; our $APP_CLASS; my $Test = Test::Builder->new(); @@ -66,13 +67,13 @@ sub BUILD { 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 ) @@ -94,31 +95,32 @@ sub _make_request { $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; } @@ -126,6 +128,26 @@ sub _make_request { 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) = @_; @@ -140,24 +162,21 @@ sub _do_catalyst_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 @@ -166,7 +185,7 @@ sub _do_catalyst_request { 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' ) { @@ -215,6 +234,7 @@ sub _do_remote_request { $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); } @@ -222,8 +242,8 @@ sub import { 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; } @@ -525,7 +545,7 @@ L, L. =head1 AUTHOR -Ash Berlin C<< >> (current maintiner) +Ash Berlin C<< >> (current maintainer) Original Author: Leon Brocard, C<< >>