X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FWWW%2FMechanize%2FCatalyst.pm;h=e9e91c6ae8db3c485a0b0f67daee2f142e108fb3;hb=dabec5e2ff6722fb97852568b29a7890582b8dd1;hp=72e4072c358911e2be0da9ae7111b4843bc30fdd;hpb=254eca4135088b598bc59093b98475992b4bf6f5;p=catagits%2FTest-WWW-Mechanize-Catalyst.git diff --git a/lib/Test/WWW/Mechanize/Catalyst.pm b/lib/Test/WWW/Mechanize/Catalyst.pm index 72e4072..e9e91c6 100644 --- a/lib/Test/WWW/Mechanize/Catalyst.pm +++ b/lib/Test/WWW/Mechanize/Catalyst.pm @@ -1,7 +1,6 @@ package Test::WWW::Mechanize::Catalyst; -use strict; -use warnings; +use Moose; use Carp qw/croak/; require Catalyst::Test; # Do not call import @@ -9,62 +8,73 @@ use Encode qw(); use HTML::Entities; use Test::WWW::Mechanize; -use base qw(Test::WWW::Mechanize); +extends 'Test::WWW::Mechanize', 'Moose::Object'; -our $VERSION = '0.45'; +use namespace::clean -execept => 'meta'; + +our $VERSION = '0.50'; +our $APP_CLASS; my $Test = Test::Builder->new(); -# the reason for the auxiliary package is that both WWW::Mechanize and -# Catalyst::Test have a subroutine named 'request' +has catalyst_app => ( + is => 'ro', + predicate => 'has_catalyst_app', +); + +has allow_external => ( + is => 'rw', + isa => 'Bool', + default => 0 +); + +has host => ( + is => 'rw', + isa => 'Str', + clearer => 'clear_host', + predicate => 'has_host', +); -our $APP_CLASS; sub new { - my ($class, %args) = @_; - - my $app; - if (exists $args{catalyst_app}) { - $app = $args{catalyst_app}; - - require Class::Inspector->filename( $app ) - unless Class::Inspector->loaded( $app ); - } elsif (!defined $APP_CLASS) { - croak 'Please provide a catalyst_app option or import Test::WWW::Mechanize::Catalyst with a class name'; - } else { - $app = $APP_CLASS; - } + my $class = shift; + + my $args = ref $_[0] ? $_[0] : { @_ }; + + # Dont let LWP complain about options for our attributes + my %attr_options = map { + my $n = $_->init_arg; + defined $n && exists $args->{$n} + ? ( $n => delete $args->{$n} ) + : ( ); + } $class->meta->get_all_attributes; + + my $obj = $class->SUPER::new(%$args); + my $self = $class->meta->new_object( + __INSTANCE__ => $obj, + ($APP_CLASS ? (catalyst_app => $APP_CLASS) : () ), + %attr_options + ); + + $self->BUILDALL; + - my $self = $class->SUPER::new(%args); - $self->{catalyst_app} = $app; return $self; } -sub allow_external { - my ( $self, $value ) = @_; - return $self->{allow_external} unless defined $value; - $self->{allow_external} = $value; +sub BUILD { + my ($self) = @_; + + 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)); + } } sub _make_request { my ( $self, $request ) = @_; - $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar; - if ( $self->{allow_external} ) { - unless ( $request->uri->as_string =~ m{^/} - || $request->uri->host eq 'localhost' ) - { - return $self->SUPER::_make_request($request); - } - } - - my $uri = $request->uri; - if ($uri->as_string =~ m{^/}) { - $uri->scheme('http'); - $uri->host('localhost'); - } - my @creds = $self->get_basic_credentials( "Basic", $uri ); - $request->authorization_basic( @creds ) if @creds; - - my $response = Catalyst::Test::local_request($self->{catalyst_app}, $request); + my $response = $self->_do_catalyst_request($request); $response->header( 'Content-Base', $request->uri ); $response->request($request); if ( $request->uri->as_string =~ m{^/} ) { @@ -118,13 +128,53 @@ sub _make_request { return $response; } +sub _do_catalyst_request { + my ($self, $request) = @_; + + my $uri = $request->uri; + $uri->scheme('http') unless defined $uri->scheme; + $uri->host('localhost') unless defined $uri->host; + + $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar; + + # Woe betide anyone who unsets CATALYST_SERVER + return Catalyst::Test::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; + + $request->header('Host', $host); + } + + if ( $self->{allow_external} ) { + unless ( $request->uri->as_string =~ m{^/} + || $request->uri->host eq 'localhost' ) + { + return $self->SUPER::_make_request($request); + } + } + + my @creds = $self->get_basic_credentials( "Basic", $uri ); + $request->authorization_basic( @creds ) if @creds; + + return Catalyst::Test::local_request($self->{catalyst_app}, $request); +} + sub import { my ($class, $app) = @_; + if (defined $app) { - require Class::Inspector->filename( $app ) - unless Class::Inspector->loaded( $app ); + Class::MOP::load_class($app) + unless (Class::MOP::is_class_loaded($app)); $APP_CLASS = $app; } + } @@ -139,16 +189,21 @@ Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst =head1 SYNOPSIS # We're in a t/*.t test script... + use Test::WWW::Mechanize::Catalyst; + # To test a Catalyst application named 'Catty': - use Test::WWW::Mechanize::Catalyst 'Catty'; + my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty'); - my $mech = Test::WWW::Mechanize::Catalyst->new; $mech->get_ok("/"); # no hostname needed is($mech->ct, "text/html"); $mech->title_is("Root", "On the root page"); $mech->content_contains("This is the root page", "Correct content"); $mech->follow_link_ok({text => 'Hello'}, "Click on Hello"); # ... and all other Test::WWW::Mechanize methods + + # White label site testing + $mech->host("foo.com"); + $mech->get_ok("/"); =head1 DESCRIPTION @@ -228,6 +283,24 @@ single sign-on system. You must set allow_external to true for this: $m->allow_external(1); +head2 catalyst_app + +The name of the Catalyst app which we are testing against. Read-only. + +=head2 host + +The host value to set the "Host:" HTTP header to, if none is present already in +the request. If not set (default) then Catalyst::Test will set this to +localhost:80 + +=head2 clear_host + +Unset the host attribute. + +=head2 has_host + +Do we have a value set for the host attribute + =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc) A wrapper around WWW::Mechanize's get(), with similar options, except the @@ -378,9 +451,9 @@ L, L. =head1 AUTHOR -Current Maintainer: Ash Berlin C<< >> +Ash Berlin C<< >> (current maintiner) -Leon Brocard, C<< >> +Original Author: Leon Brocard, C<< >> =head1 COPYRIGHT