Fix infinite redirects. RT#76614
[catagits/Test-WWW-Mechanize-Catalyst.git] / lib / Test / WWW / Mechanize / Catalyst.pm
index e9e91c6..4b05075 100644 (file)
@@ -10,9 +10,9 @@ use Test::WWW::Mechanize;
 
 extends 'Test::WWW::Mechanize', 'Moose::Object';
 
-use namespace::clean -execept => 'meta';
+#use namespace::clean -execept => 'meta';
 
-our $VERSION = '0.50';
+our $VERSION = '0.57';
 our $APP_CLASS;
 my $Test = Test::Builder->new();
 
@@ -72,15 +72,12 @@ 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', $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
@@ -97,30 +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;
     }
@@ -128,6 +127,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) = @_;
 
@@ -135,35 +154,87 @@ sub _do_catalyst_request {
     $uri->scheme('http') unless defined $uri->scheme;
     $uri->host('localhost') unless defined $uri->host;
 
+    $request = $self->prepare_request($request);
     $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};
 
+    $self->_set_host_header($request);
 
+    my $res = $self->_check_external_request($request);
+    return $res if $res;
 
-    # If there's no Host header, set one.
-    unless ($request->header('Host')) {
-      my $host = $self->has_host
-               ? $self->host
-               : $uri->host;
+    my @creds = $self->get_basic_credentials( "Basic", $uri );
+    $request->authorization_basic( @creds ) if @creds;
 
-      $request->header('Host', $host);
+    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.
+    $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);
     }
-  
-    if ( $self->{allow_external} ) {
-        unless ( $request->uri->as_string =~ m{^/}
-            || $request->uri->host eq 'localhost' )
-        {
-            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 . '/' );
         }
     }
-  
-    my @creds = $self->get_basic_credentials( "Basic", $uri );
-    $request->authorization_basic( @creds ) if @creds;
 
-    return Catalyst::Test::local_request($self->{catalyst_app}, $request);
+    $request->uri->scheme( $server->scheme );
+    $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);
 }
 
 sub import {
@@ -207,16 +278,16 @@ Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
 
 =head1 DESCRIPTION
 
-L<Catalyst> is an elegant MVC Web Application
-Framework. L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that
-incorporates features for web application testing. The
-L<Test::WWW::Mechanize::Catalyst> module meshes the two to allow easy
-testing of L<Catalyst> applications without starting up a web server.
+L<Catalyst> is an elegant MVC Web Application Framework.
+L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that incorporates
+features for web application testing. The L<Test::WWW::Mechanize::Catalyst>
+module meshes the two to allow easy testing of L<Catalyst> applications without
+needing to start up a web server.
 
 Testing web applications has always been a bit tricky, normally
-starting a web server for your application and making real HTTP
+requiring starting a web server for your application and making real HTTP
 requests to it. This module allows you to test L<Catalyst> web
-applications but does not start a server or issue HTTP
+applications but does not require a server or issue HTTP
 requests. Instead, it passes the HTTP request object directly to
 L<Catalyst>. Thus you do not need to use a real hostname:
 "http://localhost/" will do. However, this is optional. The following
@@ -229,16 +300,23 @@ Links which do not begin with / or are not for localhost can be handled
 as normal Web requests - this is handy if you have an external 
 single sign-on system. You must set allow_external to true for this:
 
-  $m->allow_external(1);
+  $mech->allow_external(1);
 
 You can also test a remote server by setting the environment variable
-CATALYST_SERVER, for example:
+CATALYST_SERVER; for example:
 
   $ CATALYST_SERVER=http://example.com/myapp prove -l t
 
 will run the same tests on the application running at
 http://example.com/myapp regardless of whether or not you specify
 http:://localhost for Test::WWW::Mechanize::Catalyst.    
+
+Furthermore, if you set CATALYST_SERVER, the server will be regarded 
+as a remote server even if your links point to localhost. Thus, you
+can use Test::WWW::Mechanize::Catalyst to test your live webserver
+running on your local machine, if you need to test aspects of your
+deployment environment (for example, configuration options in an
+http.conf file) instead of just the Catalyst request handling.
     
 This makes testing fast and easy. L<Test::WWW::Mechanize> provides
 functions for common web testing scenarios. For example:
@@ -253,12 +331,12 @@ This module supports cookies automatically.
 To use this module you must pass it the name of the application. See
 the SYNOPSIS above.
 
-Note that Catalyst has a special developing feature: the debug
+Note that Catalyst has a special development feature: the debug
 screen. By default this module will treat responses which are the
 debug screen as failures. If you actually want to test debug screens,
 please use:
 
-  $m->{catalyst_debug} = 1;
+  $mech->{catalyst_debug} = 1;
 
 An alternative to this module is L<Catalyst::Test>.
 
@@ -266,7 +344,7 @@ An alternative to this module is L<Catalyst::Test>.
 
 =head2 new
 
-Behaves like, and calls, L<WWW::Mechanize>'s C<new> method.  Any parms
+Behaves like, and calls, L<WWW::Mechanize>'s C<new> method.  Any params
 passed in get passed to WWW::Mechanize's constructor. Note that we
 need to pass the name of the Catalyst application to the "use":
 
@@ -281,7 +359,7 @@ Links which do not begin with / or are not for localhost can be handled
 as normal Web requests - this is handy if you have an external 
 single sign-on system. You must set allow_external to true for this:
 
-  $m->allow_external(1);
+  $mech->allow_external(1);
 
 head2 catalyst_app
 
@@ -321,13 +399,13 @@ Tells if the title of the page matches the given regex.
 
 =head2 $mech->title_unlike( $regex [, $desc ] )
 
-Tells if the title of the page matches the given regex.
+Tells if the title of the page does NOT match the given regex.
 
     $mech->title_unlike( qr/Invoices for (.+)/
 
 =head2 $mech->content_is( $str [, $desc ] )
 
-Tells if the content of the page matches the given string
+Tells if the content of the page matches the given string.
 
 =head2 $mech->content_contains( $str [, $desc ] )
 
@@ -416,7 +494,7 @@ or a scalar URL name.
 
 =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
 
-Check the current page for specified links and test the content of each
+Check the current page for specified links and test that the content of each
 does not match I<$regex>.  The links may be specified as a reference to
 an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
 or a scalar URL name.
@@ -431,11 +509,11 @@ Makes a C<follow_link()> call and executes tests on the results.
 The link must be found, and then followed successfully.  Otherwise,
 this test fails.
 
-I<%parms> is a hashref containing the parms to pass to C<follow_link()>.
-Note that the parms to C<follow_link()> are a hash whereas the parms to
+I<%parms> is a hashref containing the params to pass to C<follow_link()>.
+Note that the params to C<follow_link()> are a hash whereas the parms to
 this function are a hashref.  You have to call this function like:
 
-    $agent->follow_like_ok( {n=>3}, "looking for 3rd link" );
+    $agent->follow_link_ok( {n=>3}, "looking for 3rd link" );
 
 As with other test functions, C<$comment> is optional.  If it is supplied
 then it will display when running the test harness in verbose mode.
@@ -444,6 +522,21 @@ Returns true value if the specified link was found and followed
 successfully.  The HTTP::Response object returned by follow_link()
 is not available.
 
+=head1 CAVEATS
+
+=head2 External Redirects and allow_external
+
+If you use non-fully qualified urls in your test scripts (i.e. anything without
+a host, such as C<< ->get_ok( "/foo") >> ) and your app redirects to an
+external URL, expect to be bitten once you come back to your application's urls
+(it will try to request them on the remote server). This is due to a limitation
+in WWW::Mechanize.
+
+One workaround for this is that if you are expecting to redirect to an external
+site, clone the TWMC object and use the cloned object for the external
+redirect.
+
+
 =head1 SEE ALSO
 
 Related modules which may be of interest: L<Catalyst>,
@@ -457,7 +550,7 @@ Original Author: Leon Brocard, C<< <acme@astray.com> >>
 
 =head1 COPYRIGHT
 
-Copyright (C) 2005-8, Leon Brocard
+Copyright (C) 2005-9, Leon Brocard
 
 =head1 LICENSE