[Catalyst-commits] r14299 - in Test-WWW-Mechanize-Catalyst/trunk: .
lib/Test/WWW/Mechanize t
t0m at dev.catalyst.perl.org
t0m at dev.catalyst.perl.org
Sun May 13 20:06:12 GMT 2012
Author: t0m
Date: 2012-05-13 20:06:12 +0000 (Sun, 13 May 2012)
New Revision: 14299
Modified:
Test-WWW-Mechanize-Catalyst/trunk/CHANGES
Test-WWW-Mechanize-Catalyst/trunk/Makefile.PL
Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm
Test-WWW-Mechanize-Catalyst/trunk/t/redirect.t
Log:
Fix infinite redirects. RT#76614
Modified: Test-WWW-Mechanize-Catalyst/trunk/CHANGES
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/CHANGES 2012-05-13 20:05:22 UTC (rev 14298)
+++ Test-WWW-Mechanize-Catalyst/trunk/CHANGES 2012-05-13 20:06:12 UTC (rev 14299)
@@ -1,5 +1,6 @@
Revision history for Perl module Test::WWW::Mechanize::Catalyst:
+ - Fix infinite redirects. RT#76614
- Make fail to start server more verbose. RT#77174
- Fix test skip count. RT#77181
Modified: Test-WWW-Mechanize-Catalyst/trunk/Makefile.PL
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/Makefile.PL 2012-05-13 20:05:22 UTC (rev 14298)
+++ Test-WWW-Mechanize-Catalyst/trunk/Makefile.PL 2012-05-13 20:06:12 UTC (rev 14299)
@@ -18,7 +18,7 @@
test_requires 'Catalyst::Plugin::Session::State::Cookie' => '0';
test_requires 'Catalyst::Plugin::Session::Store::Dummy' => '0';
test_requires 'Test::Exception' => '0';
-test_requires 'Test::More' => '0';
+test_requires 'Test::More' => '0.88';
test_requires 'Test::utf8' => '0';
if ($Module::Install::AUTHOR) {
Modified: Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm 2012-05-13 20:05:22 UTC (rev 14298)
+++ Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm 2012-05-13 20:06:12 UTC (rev 14299)
@@ -72,7 +72,7 @@
}
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 +94,32 @@
$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 +127,14 @@
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.
Modified: Test-WWW-Mechanize-Catalyst/trunk/t/redirect.t
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/redirect.t 2012-05-13 20:05:22 UTC (rev 14298)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/redirect.t 2012-05-13 20:06:12 UTC (rev 14299)
@@ -2,7 +2,7 @@
use strict;
use warnings;
use lib 'lib';
-use Test::More tests => 30;
+use Test::More;
use lib 't/lib';
use Test::WWW::Mechanize::Catalyst 'Catty';
use HTTP::Request::Common;
@@ -42,3 +42,34 @@
my $uri = URI->new_abs( $loc, $req->uri )->as_string;
is_sane_utf8($uri);
isnt_flagged_utf8($uri);
+
+# Check for max_redirects support
+{
+ $m = Test::WWW::Mechanize::Catalyst->new(max_redirect => 1);
+ is( $m->max_redirect, 1, 'max_redirect set' );
+
+ $m->get( "$root/bonjour" );
+ ok( !$m->success, "get /bonjour with max_redirect=1 is not a success" );
+ is( $m->response->redirects, 1, 'redirects only once' );
+ like( $m->response->header('Client-Warning'), qr/Redirect loop detected/i,
+ 'sets Client-Warning header' );
+}
+
+# Make sure we can handle max_redirects=0
+{
+ $m = Test::WWW::Mechanize::Catalyst->new(max_redirect => 0);
+ $m->get( "$root/hello" );
+ ok( $m->success, "get /hello with max_redirect=0 succeeds" );
+ is( $m->response->redirects, 0, 'no redirects' );
+ ok( !$m->response->header('Client-Warning'), 'no Client-Warning header' );
+
+ # shouldn't be redirected if max_redirect == 0
+ $m->get( "$root/bonjour" );
+ ok( !$m->success, "get /bonjour with max_redirect=0 is not a success" );
+ is( $m->response->redirects, 0, 'no redirects' );
+ like( $m->response->header('Client-Warning'), qr/Redirect loop detected/i,
+ 'sets Client-Warning header' );
+}
+
+done_testing;
+
More information about the Catalyst-commits
mailing list