[Catalyst-commits] r14132 - in Test-WWW-Mechanize-Catalyst/tags: .
0.56 0.56/lib/Test/WWW/Mechanize
edenc at dev.catalyst.perl.org
edenc at dev.catalyst.perl.org
Fri Oct 14 00:17:06 GMT 2011
Author: edenc
Date: 2011-10-14 00:17:06 +0000 (Fri, 14 Oct 2011)
New Revision: 14132
Added:
Test-WWW-Mechanize-Catalyst/tags/0.56/
Test-WWW-Mechanize-Catalyst/tags/0.56/CHANGES
Test-WWW-Mechanize-Catalyst/tags/0.56/lib/Test/WWW/Mechanize/Catalyst.pm
Removed:
Test-WWW-Mechanize-Catalyst/tags/0.56/CHANGES
Test-WWW-Mechanize-Catalyst/tags/0.56/lib/Test/WWW/Mechanize/Catalyst.pm
Log:
tag 0.56
Deleted: Test-WWW-Mechanize-Catalyst/tags/0.56/CHANGES
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/CHANGES 2011-10-13 21:13:09 UTC (rev 14130)
+++ Test-WWW-Mechanize-Catalyst/tags/0.56/CHANGES 2011-10-14 00:17:06 UTC (rev 14132)
@@ -1,127 +0,0 @@
-Revision history for Perl module Test::WWW::Mechanize::Catalyst:
-
-0.55 Tue Sep 27 19:20 BST 2011
- - Set 'Host' header for remote requests too
-
-0.54 Mon Aug 1 20:49 BST 2011
- - change to make sure we support changes in Catalyst::Test introduced
- in the Cataplack port.
-
-0.53 Sun Dec 5 23:03 GMT 2010
- - Fix tests to work with the upcoming psgi based Catalyst release
- as $c->req->header('Host') now more accurately reflects what you
- see in a real web server (i.e. the port will not be defined if it
- is 80)
- - Fix tests to work when the CATALYST_DEBUG environment variable is
- set by explicitly setting it to 0 in tests which require it.
-
-0.52 Mon Mar 8 01:25 GMT 2010
- - Move actions out of the test applications to avoid deprecation warnings.
- - POD corrections by jhannah
- - Bump version dependency of Test::WWW::Mechanize to 1.54 to fix RT#44555
- - Wrap checks for the appropriate plugins to skip tests inside a BEGIN
- block so that they are run before the app tries to be loaded at compile
- time, fixing RT#47037
-
-0.51 Mon Mar 16 10:00 GMT 2009
- - Doc updates from thejester
- - User agent fixes from ANDREMAR
- - Fix bug where redirect was followed on a 500 response
- - All remote requests (i.e. CATALYST_SERVER env var) now use our own
- mechanize object, rather than an unconfigurable one from Catalyst:Test
-
-0.50 Tue Feb 17 09:12 GMT 2009
- - Remove warning in HTTP::Cookies
- - Call BUILDALL
-
-0.50_2 Thur Feb 12 09:47 GMT 2009
- - Make t/multi_content_type.t handle case when server cant be started,
- which is almost always due to port in use.
-
-0.50_1 Thur Feb 5 09:02 GMT 2009
- - App classname no longer has to be passed to import:
- $m = T::W::M::C->new(catalyst_app => 'Catty')
- now works.
- - Can now use TWMC two test two different apps in the same perl
- interpreter due to the above change
- - Removed Test::WWW::Mechanize::Catalyst::Aux package as it isn't needed
- any more
- - Add 'host' accessor for white-label testing
- - Moosification
- - Can now test against remote CATALYST_SERVER without having to load the
- app class
-
-0.45 Mon Nov 24 20:39:19 GMT 2008
- - be forwards-compatible with Catalyst 5.80's virtual
- domain testing (thanks Jason Gottshall)
-
-0.44 Mon Oct 27 13:48:22 GMT 2008
- - fix longstanding bug with recent LWP, requiring
- WWW::Mechanize 1.50 (thanks to petdance, mst, dakkar)
- - add machine- and human-readable license, add abstract
-
-0.43 Mon Aug 18 15:42:03 BST 2008
- - add missing prereqs to Catalyst::Plugin::Session::State::Cookie
- and Catalyst::Plugin::Session::Store::Dummy (thanks kd)
-
-0.42 Tue Apr 29 20:25:06 BST 2008
- - stop multi_content_type.t killing smoke testing
- (patch by Andreas König)
- - fix a case where HTTP::Cookies dies when trying to
- extract_cookies (patch by Andreas Marienborg)
- - add Test::Exception as a prerequisite
-
-0.41 Mon Sep 17 20:28:59 BST 2007
- - fix to cope with gzipped content and the test from the
- rt.cpan queue about multiple content types
- (patch by Ash Berlin)
-
-0.40 Tue Aug 21 20:51:13 BST 2007
- - external requests (as per last release) are now only allowed
- if you set allow_external (sorry about that)
-
-0.39 Sat Aug 4 08:01:38 BST 2007
- - external requests are now allowed (patch by Edmund von der Burg)
- - remove Build.PL
-
-0.38 Sat Jun 30 14:07:24 BST 2007
- - document and test that you can use URLs without schema
- or hostname
- - add debug screen error to test diagnostics (patch by
- Jonathan Swartz)
- - add basic authentication support (patch by Gareth Kirwan)
- - add test for charset=utf-8 (patch by Chris Dolan)
- - added CATALYST_SERVER mention in the documentation
- (patch by Kieren Diment)
-
-0.37 Tue Jun 6 08:54:07 BST 2006
- - patch to follow LWP's $m->requests_redirectable() and small
- docpatch (thanks to Daniel McBrearty)
- - mention Catalyst::Test (thanks to guest)
-
-0.36 Mon Apr 17 11:27:17 BST 2006
- - perltidy
- - Catalyst debug screens are now failures (thanks to Kieren Diment)
-
-0.35 Tue Jan 22 17:06:00 GMT 2006
- - handle redirects (patch by Mark Fowler)
-
-0.33 Tue Jun 7 17:38:45 BST 2005
- - we need at least version 1.04 of Test::WWW::Mechanize
- (spotted by Jesse Vincent, patch by Shlomi Fish)
-
-0.32 Tue May 3 16:14:40 BST 2005
- - removed 'use Image::Size' in test, as spotted by SMPETERS
-
-0.31 Sun Apr 17 10:30:18 BST 2005
- - update for Catalyst 5.00
-
-0.30 Fri Mar 25 04:34:50 GMT 2005
- - add Test::WWW::Mechanize to prereqs
- - remove useless "use URI"
- - "borrow" lots of docs from Test::WWW::Mechanize
- - Catalyst 4.30 adds support for HTTP::Request objects in
- Catalyst::Test::request(), so use it (thanks to Christian Hansen)
-
-0.29 Thu Mar 17 22:42:04 EST 2005
- - initial release
Copied: Test-WWW-Mechanize-Catalyst/tags/0.56/CHANGES (from rev 14131, Test-WWW-Mechanize-Catalyst/trunk/CHANGES)
===================================================================
--- Test-WWW-Mechanize-Catalyst/tags/0.56/CHANGES (rev 0)
+++ Test-WWW-Mechanize-Catalyst/tags/0.56/CHANGES 2011-10-14 00:17:06 UTC (rev 14132)
@@ -0,0 +1,130 @@
+Revision history for Perl module Test::WWW::Mechanize::Catalyst:
+
+0.56 Thu Oct 13 21:05 BRT 2011
+ - Add port to Host header
+
+0.55 Tue Sep 27 19:20 BST 2011
+ - Set 'Host' header for remote requests too
+
+0.54 Mon Aug 1 20:49 BST 2011
+ - change to make sure we support changes in Catalyst::Test introduced
+ in the Cataplack port.
+
+0.53 Sun Dec 5 23:03 GMT 2010
+ - Fix tests to work with the upcoming psgi based Catalyst release
+ as $c->req->header('Host') now more accurately reflects what you
+ see in a real web server (i.e. the port will not be defined if it
+ is 80)
+ - Fix tests to work when the CATALYST_DEBUG environment variable is
+ set by explicitly setting it to 0 in tests which require it.
+
+0.52 Mon Mar 8 01:25 GMT 2010
+ - Move actions out of the test applications to avoid deprecation warnings.
+ - POD corrections by jhannah
+ - Bump version dependency of Test::WWW::Mechanize to 1.54 to fix RT#44555
+ - Wrap checks for the appropriate plugins to skip tests inside a BEGIN
+ block so that they are run before the app tries to be loaded at compile
+ time, fixing RT#47037
+
+0.51 Mon Mar 16 10:00 GMT 2009
+ - Doc updates from thejester
+ - User agent fixes from ANDREMAR
+ - Fix bug where redirect was followed on a 500 response
+ - All remote requests (i.e. CATALYST_SERVER env var) now use our own
+ mechanize object, rather than an unconfigurable one from Catalyst:Test
+
+0.50 Tue Feb 17 09:12 GMT 2009
+ - Remove warning in HTTP::Cookies
+ - Call BUILDALL
+
+0.50_2 Thur Feb 12 09:47 GMT 2009
+ - Make t/multi_content_type.t handle case when server cant be started,
+ which is almost always due to port in use.
+
+0.50_1 Thur Feb 5 09:02 GMT 2009
+ - App classname no longer has to be passed to import:
+ $m = T::W::M::C->new(catalyst_app => 'Catty')
+ now works.
+ - Can now use TWMC two test two different apps in the same perl
+ interpreter due to the above change
+ - Removed Test::WWW::Mechanize::Catalyst::Aux package as it isn't needed
+ any more
+ - Add 'host' accessor for white-label testing
+ - Moosification
+ - Can now test against remote CATALYST_SERVER without having to load the
+ app class
+
+0.45 Mon Nov 24 20:39:19 GMT 2008
+ - be forwards-compatible with Catalyst 5.80's virtual
+ domain testing (thanks Jason Gottshall)
+
+0.44 Mon Oct 27 13:48:22 GMT 2008
+ - fix longstanding bug with recent LWP, requiring
+ WWW::Mechanize 1.50 (thanks to petdance, mst, dakkar)
+ - add machine- and human-readable license, add abstract
+
+0.43 Mon Aug 18 15:42:03 BST 2008
+ - add missing prereqs to Catalyst::Plugin::Session::State::Cookie
+ and Catalyst::Plugin::Session::Store::Dummy (thanks kd)
+
+0.42 Tue Apr 29 20:25:06 BST 2008
+ - stop multi_content_type.t killing smoke testing
+ (patch by Andreas König)
+ - fix a case where HTTP::Cookies dies when trying to
+ extract_cookies (patch by Andreas Marienborg)
+ - add Test::Exception as a prerequisite
+
+0.41 Mon Sep 17 20:28:59 BST 2007
+ - fix to cope with gzipped content and the test from the
+ rt.cpan queue about multiple content types
+ (patch by Ash Berlin)
+
+0.40 Tue Aug 21 20:51:13 BST 2007
+ - external requests (as per last release) are now only allowed
+ if you set allow_external (sorry about that)
+
+0.39 Sat Aug 4 08:01:38 BST 2007
+ - external requests are now allowed (patch by Edmund von der Burg)
+ - remove Build.PL
+
+0.38 Sat Jun 30 14:07:24 BST 2007
+ - document and test that you can use URLs without schema
+ or hostname
+ - add debug screen error to test diagnostics (patch by
+ Jonathan Swartz)
+ - add basic authentication support (patch by Gareth Kirwan)
+ - add test for charset=utf-8 (patch by Chris Dolan)
+ - added CATALYST_SERVER mention in the documentation
+ (patch by Kieren Diment)
+
+0.37 Tue Jun 6 08:54:07 BST 2006
+ - patch to follow LWP's $m->requests_redirectable() and small
+ docpatch (thanks to Daniel McBrearty)
+ - mention Catalyst::Test (thanks to guest)
+
+0.36 Mon Apr 17 11:27:17 BST 2006
+ - perltidy
+ - Catalyst debug screens are now failures (thanks to Kieren Diment)
+
+0.35 Tue Jan 22 17:06:00 GMT 2006
+ - handle redirects (patch by Mark Fowler)
+
+0.33 Tue Jun 7 17:38:45 BST 2005
+ - we need at least version 1.04 of Test::WWW::Mechanize
+ (spotted by Jesse Vincent, patch by Shlomi Fish)
+
+0.32 Tue May 3 16:14:40 BST 2005
+ - removed 'use Image::Size' in test, as spotted by SMPETERS
+
+0.31 Sun Apr 17 10:30:18 BST 2005
+ - update for Catalyst 5.00
+
+0.30 Fri Mar 25 04:34:50 GMT 2005
+ - add Test::WWW::Mechanize to prereqs
+ - remove useless "use URI"
+ - "borrow" lots of docs from Test::WWW::Mechanize
+ - Catalyst 4.30 adds support for HTTP::Request objects in
+ Catalyst::Test::request(), so use it (thanks to Christian Hansen)
+
+0.29 Thu Mar 17 22:42:04 EST 2005
+ - initial release
Deleted: Test-WWW-Mechanize-Catalyst/tags/0.56/lib/Test/WWW/Mechanize/Catalyst.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm 2011-10-13 21:13:09 UTC (rev 14130)
+++ Test-WWW-Mechanize-Catalyst/tags/0.56/lib/Test/WWW/Mechanize/Catalyst.pm 2011-10-14 00:17:06 UTC (rev 14132)
@@ -1,550 +0,0 @@
-package Test::WWW::Mechanize::Catalyst;
-
-use Moose;
-
-use Carp qw/croak/;
-require Catalyst::Test; # Do not call import
-use Encode qw();
-use HTML::Entities;
-use Test::WWW::Mechanize;
-
-extends 'Test::WWW::Mechanize', 'Moose::Object';
-
-#use namespace::clean -execept => 'meta';
-
-our $VERSION = '0.55';
-our $APP_CLASS;
-my $Test = Test::Builder->new();
-
-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',
-);
-
-sub new {
- 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;
-
-
- return $self;
-}
-
-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 ) = @_;
-
- my $response = $self->_do_catalyst_request($request);
- $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
- if ( !$self->{catalyst_debug}
- && $response->code == 500
- && $response->content =~ /on Catalyst \d+\.\d+/ )
- {
- my ($error)
- = ( $response->content =~ /<code class="error">(.*?)<\/code>/s );
- $error ||= "unknown error";
- decode_entities($error);
- $Test->diag("Catalyst error screen: $error");
- $response->content('');
- $response->content_type('');
- }
-
- # check if that was a redirect
- if ( $response->header('Location')
- && $response->is_redirect
- && $self->redirect_ok( $request, $response ) )
- {
-
- # remember the old response
- my $old_response = $response;
-
- # *where* do they want us to redirect to?
- my $location = $old_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
- } else {
- $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) = @_;
-
- my $uri = $request->uri;
- $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 $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;
-
- my @creds = $self->get_basic_credentials( "Basic", $uri );
- $request->authorization_basic( @creds ) if @creds;
-
- 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);
- }
- 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 . '/' );
- }
- }
-
- $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 {
- my ($class, $app) = @_;
-
- if (defined $app) {
- Class::MOP::load_class($app)
- unless (Class::MOP::is_class_loaded($app));
- $APP_CLASS = $app;
- }
-
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-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':
- my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
-
- $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
-
-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
-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 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
-two lines of code do exactly the same thing:
-
- $mech->get_ok('/action');
- $mech->get_ok('http://localhost/action');
-
-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:
-
- $mech->allow_external(1);
-
-You can also test a remote server by setting the environment variable
-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:
-
- $mech->get_ok( $page );
- $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
- $mech->content_contains( "Andy Lester", "My name somewhere" );
- $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
-
-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 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:
-
- $mech->{catalyst_debug} = 1;
-
-An alternative to this module is L<Catalyst::Test>.
-
-=head1 CONSTRUCTOR
-
-=head2 new
-
-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":
-
- use Test::WWW::Mechanize::Catalyst 'Catty';
- my $mech = Test::WWW::Mechanize::Catalyst->new;
-
-=head1 METHODS
-
-=head2 allow_external
-
-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:
-
- $mech->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
-second argument needs to be a hash reference, not a hash. Returns true or
-false.
-
-=head2 $mech->title_is( $str [, $desc ] )
-
-Tells if the title of the page is the given string.
-
- $mech->title_is( "Invoice Summary" );
-
-=head2 $mech->title_like( $regex [, $desc ] )
-
-Tells if the title of the page matches the given regex.
-
- $mech->title_like( qr/Invoices for (.+)/
-
-=head2 $mech->title_unlike( $regex [, $desc ] )
-
-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.
-
-=head2 $mech->content_contains( $str [, $desc ] )
-
-Tells if the content of the page contains I<$str>.
-
-=head2 $mech->content_lacks( $str [, $desc ] )
-
-Tells if the content of the page lacks I<$str>.
-
-=head2 $mech->content_like( $regex [, $desc ] )
-
-Tells if the content of the page matches I<$regex>.
-
-=head2 $mech->content_unlike( $regex [, $desc ] )
-
-Tells if the content of the page does NOT match I<$regex>.
-
-=head2 $mech->page_links_ok( [ $desc ] )
-
-Follow all links on the current page and test for HTTP status 200
-
- $mech->page_links_ok('Check all links');
-
-=head2 $mech->page_links_content_like( $regex,[ $desc ] )
-
-Follow all links on the current page and test their contents for I<$regex>.
-
- $mech->page_links_content_like( qr/foo/,
- 'Check all links contain "foo"' );
-
-=head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
-
-Follow all links on the current page and test their contents do not
-contain the specified regex.
-
- $mech->page_links_content_unlike(qr/Restricted/,
- 'Check all links do not contain Restricted');
-
-=head2 $mech->links_ok( $links [, $desc ] )
-
-Check the current page for specified links and test for HTTP status
-200. 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.
-
- my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
- $mech->links_ok( \@links, 'Check all links for cnn.com' );
-
- my @links = qw( index.html search.html about.html );
- $mech->links_ok( \@links, 'Check main links' );
-
- $mech->links_ok( 'index.html', 'Check link to index' );
-
-=head2 $mech->link_status_is( $links, $status [, $desc ] )
-
-Check the current page for specified links and test for HTTP status
-passed. 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.
-
- my @links = $mech->links();
- $mech->link_status_is( \@links, 403,
- 'Check all links are restricted' );
-
-=head2 $mech->link_status_isnt( $links, $status [, $desc ] )
-
-Check the current page for specified links and test for HTTP status
-passed. 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.
-
- my @links = $mech->links();
- $mech->link_status_isnt( \@links, 404,
- 'Check all links are not 404' );
-
-=head2 $mech->link_content_like( $links, $regex [, $desc ] )
-
-Check the current page for specified links and test the content of
-each against 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.
-
- my @links = $mech->links();
- $mech->link_content_like( \@links, qr/Restricted/,
- 'Check all links are restricted' );
-
-=head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
-
-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.
-
- my @links = $mech->links();
- $mech->link_content_like( \@links, qr/Restricted/,
- 'Check all links are restricted' );
-
-=head2 follow_link_ok( \%parms [, $comment] )
-
-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 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_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.
-
-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>,
-L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
-
-=head1 AUTHOR
-
-Ash Berlin C<< <ash at cpan.org> >> (current maintiner)
-
-Original Author: Leon Brocard, C<< <acme at astray.com> >>
-
-=head1 COPYRIGHT
-
-Copyright (C) 2005-9, Leon Brocard
-
-=head1 LICENSE
-
-This module is free software; you can redistribute it or modify it
-under the same terms as Perl itself.
-
Copied: Test-WWW-Mechanize-Catalyst/tags/0.56/lib/Test/WWW/Mechanize/Catalyst.pm (from rev 14131, Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm)
===================================================================
--- Test-WWW-Mechanize-Catalyst/tags/0.56/lib/Test/WWW/Mechanize/Catalyst.pm (rev 0)
+++ Test-WWW-Mechanize-Catalyst/tags/0.56/lib/Test/WWW/Mechanize/Catalyst.pm 2011-10-14 00:17:06 UTC (rev 14132)
@@ -0,0 +1,550 @@
+package Test::WWW::Mechanize::Catalyst;
+
+use Moose;
+
+use Carp qw/croak/;
+require Catalyst::Test; # Do not call import
+use Encode qw();
+use HTML::Entities;
+use Test::WWW::Mechanize;
+
+extends 'Test::WWW::Mechanize', 'Moose::Object';
+
+#use namespace::clean -execept => 'meta';
+
+our $VERSION = '0.56';
+our $APP_CLASS;
+my $Test = Test::Builder->new();
+
+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',
+);
+
+sub new {
+ 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;
+
+
+ return $self;
+}
+
+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 ) = @_;
+
+ my $response = $self->_do_catalyst_request($request);
+ $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
+ if ( !$self->{catalyst_debug}
+ && $response->code == 500
+ && $response->content =~ /on Catalyst \d+\.\d+/ )
+ {
+ my ($error)
+ = ( $response->content =~ /<code class="error">(.*?)<\/code>/s );
+ $error ||= "unknown error";
+ decode_entities($error);
+ $Test->diag("Catalyst error screen: $error");
+ $response->content('');
+ $response->content_type('');
+ }
+
+ # check if that was a redirect
+ if ( $response->header('Location')
+ && $response->is_redirect
+ && $self->redirect_ok( $request, $response ) )
+ {
+
+ # remember the old response
+ my $old_response = $response;
+
+ # *where* do they want us to redirect to?
+ my $location = $old_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
+ } else {
+ $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) = @_;
+
+ my $uri = $request->uri;
+ $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 $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;
+
+ my @creds = $self->get_basic_credentials( "Basic", $uri );
+ $request->authorization_basic( @creds ) if @creds;
+
+ 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);
+ }
+ 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 . '/' );
+ }
+ }
+
+ $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 {
+ my ($class, $app) = @_;
+
+ if (defined $app) {
+ Class::MOP::load_class($app)
+ unless (Class::MOP::is_class_loaded($app));
+ $APP_CLASS = $app;
+ }
+
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+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':
+ my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
+
+ $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
+
+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
+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 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
+two lines of code do exactly the same thing:
+
+ $mech->get_ok('/action');
+ $mech->get_ok('http://localhost/action');
+
+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:
+
+ $mech->allow_external(1);
+
+You can also test a remote server by setting the environment variable
+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:
+
+ $mech->get_ok( $page );
+ $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
+ $mech->content_contains( "Andy Lester", "My name somewhere" );
+ $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
+
+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 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:
+
+ $mech->{catalyst_debug} = 1;
+
+An alternative to this module is L<Catalyst::Test>.
+
+=head1 CONSTRUCTOR
+
+=head2 new
+
+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":
+
+ use Test::WWW::Mechanize::Catalyst 'Catty';
+ my $mech = Test::WWW::Mechanize::Catalyst->new;
+
+=head1 METHODS
+
+=head2 allow_external
+
+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:
+
+ $mech->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
+second argument needs to be a hash reference, not a hash. Returns true or
+false.
+
+=head2 $mech->title_is( $str [, $desc ] )
+
+Tells if the title of the page is the given string.
+
+ $mech->title_is( "Invoice Summary" );
+
+=head2 $mech->title_like( $regex [, $desc ] )
+
+Tells if the title of the page matches the given regex.
+
+ $mech->title_like( qr/Invoices for (.+)/
+
+=head2 $mech->title_unlike( $regex [, $desc ] )
+
+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.
+
+=head2 $mech->content_contains( $str [, $desc ] )
+
+Tells if the content of the page contains I<$str>.
+
+=head2 $mech->content_lacks( $str [, $desc ] )
+
+Tells if the content of the page lacks I<$str>.
+
+=head2 $mech->content_like( $regex [, $desc ] )
+
+Tells if the content of the page matches I<$regex>.
+
+=head2 $mech->content_unlike( $regex [, $desc ] )
+
+Tells if the content of the page does NOT match I<$regex>.
+
+=head2 $mech->page_links_ok( [ $desc ] )
+
+Follow all links on the current page and test for HTTP status 200
+
+ $mech->page_links_ok('Check all links');
+
+=head2 $mech->page_links_content_like( $regex,[ $desc ] )
+
+Follow all links on the current page and test their contents for I<$regex>.
+
+ $mech->page_links_content_like( qr/foo/,
+ 'Check all links contain "foo"' );
+
+=head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
+
+Follow all links on the current page and test their contents do not
+contain the specified regex.
+
+ $mech->page_links_content_unlike(qr/Restricted/,
+ 'Check all links do not contain Restricted');
+
+=head2 $mech->links_ok( $links [, $desc ] )
+
+Check the current page for specified links and test for HTTP status
+200. 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.
+
+ my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
+ $mech->links_ok( \@links, 'Check all links for cnn.com' );
+
+ my @links = qw( index.html search.html about.html );
+ $mech->links_ok( \@links, 'Check main links' );
+
+ $mech->links_ok( 'index.html', 'Check link to index' );
+
+=head2 $mech->link_status_is( $links, $status [, $desc ] )
+
+Check the current page for specified links and test for HTTP status
+passed. 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.
+
+ my @links = $mech->links();
+ $mech->link_status_is( \@links, 403,
+ 'Check all links are restricted' );
+
+=head2 $mech->link_status_isnt( $links, $status [, $desc ] )
+
+Check the current page for specified links and test for HTTP status
+passed. 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.
+
+ my @links = $mech->links();
+ $mech->link_status_isnt( \@links, 404,
+ 'Check all links are not 404' );
+
+=head2 $mech->link_content_like( $links, $regex [, $desc ] )
+
+Check the current page for specified links and test the content of
+each against 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.
+
+ my @links = $mech->links();
+ $mech->link_content_like( \@links, qr/Restricted/,
+ 'Check all links are restricted' );
+
+=head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
+
+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.
+
+ my @links = $mech->links();
+ $mech->link_content_like( \@links, qr/Restricted/,
+ 'Check all links are restricted' );
+
+=head2 follow_link_ok( \%parms [, $comment] )
+
+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 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_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.
+
+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>,
+L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
+
+=head1 AUTHOR
+
+Ash Berlin C<< <ash at cpan.org> >> (current maintiner)
+
+Original Author: Leon Brocard, C<< <acme at astray.com> >>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-9, Leon Brocard
+
+=head1 LICENSE
+
+This module is free software; you can redistribute it or modify it
+under the same terms as Perl itself.
+
More information about the Catalyst-commits
mailing list