Fix infinite redirects. RT#76614

diff --git a/CHANGES b/CHANGES
index 2ee7743..a4a94be 100644 (file)
--- a/CHANGES
+++ b/CHANGES
@@ -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
 

diff --git a/Makefile.PL b/Makefile.PL
index 0471ffb..20019eb 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -18,7 +18,7 @@ requires 'namespace::clean'                         => '0.09';
 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) {

diff --git a/lib/Test/WWW/Mechanize/Catalyst.pm b/lib/Test/WWW/Mechanize/Catalyst.pm
index 7451c83..4b05075 100644 (file)
--- a/lib/Test/WWW/Mechanize/Catalyst.pm
+++ b/lib/Test/WWW/Mechanize/Catalyst.pm
@@ -72,7 +72,7 @@ sub BUILD {
 }
 
 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 @@ 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 +127,14 @@ 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.

diff --git a/t/redirect.t b/t/redirect.t
index 34ee311..a1a1603 100644 (file)
--- a/t/redirect.t
+++ b/t/redirect.t
@@ -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 $loc = $m->_do_catalyst_request($req)->header('Location');
 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;
+