package Test::WWW::Mechanize::Catalyst;
-use strict;
-use warnings;
+use Moose;
use Carp qw/croak/;
require Catalyst::Test; # Do not call import
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{^/} ) {
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;
}
+
}
=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
$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
=head1 AUTHOR
-Current Maintainer: Ash Berlin C<< <ash@cpan.org> >>
+Ash Berlin C<< <ash@cpan.org> >> (current maintiner)
-Leon Brocard, C<< <acme@astray.com> >>
+Original Author: Leon Brocard, C<< <acme@astray.com> >>
=head1 COPYRIGHT
projects / catagits/Test-WWW-Mechanize-Catalyst.git / blobdiff