X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FWWW%2FMechanize%2FCatalyst.pm;h=9135724f655c635f0ecbc2a1897b530f774f4f91;hb=2e30e0bafdce5623b4588de91c469a82b08d333b;hp=9f6f1f855826ede181dc1729882247afe6aefca5;hpb=f319e68f279e94587cbd6760dffd208f79567e81;p=catagits%2FTest-WWW-Mechanize-Catalyst.git

diff --git a/lib/Test/WWW/Mechanize/Catalyst.pm b/lib/Test/WWW/Mechanize/Catalyst.pm
index 9f6f1f8..9135724 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.51';
+our $VERSION = '0.58';
 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; 
   }
 
@@ -263,7 +283,7 @@ 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 starting up a web server.
+needing to start up a web server.
 
 Testing web applications has always been a bit tricky, normally
 requiring starting a web server for your application and making real HTTP
@@ -312,12 +332,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:
 
-  $mmech->{catalyst_debug} = 1;
+  $mech->{catalyst_debug} = 1;
 
 An alternative to this module is L<Catalyst::Test>.
 
@@ -340,7 +360,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
 
@@ -386,7 +406,7 @@ Tells if the title of the page does NOT match the given regex.
 
 =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 ] )
 
@@ -475,7 +495,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.
@@ -510,11 +530,11 @@ is not available.
 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
+(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 obeject and use the cloned object for the external
+site, clone the TWMC object and use the cloned object for the external
 redirect.
 
 
@@ -525,13 +545,13 @@ L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
 
 =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> >>
 
 =head1 COPYRIGHT
 
-Copyright (C) 2005-8, Leon Brocard
+Copyright (C) 2005-9, Leon Brocard
 
 =head1 LICENSE