[Catalyst-commits] r9164 - / Test-WWW-Mechanize-Catalyst
Test-WWW-Mechanize-Catalyst/trunk
Test-WWW-Mechanize-Catalyst/trunk/lib
Test-WWW-Mechanize-Catalyst/trunk/lib/Test
Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW
Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize
Test-WWW-Mechanize-Catalyst/trunk/t
Test-WWW-Mechanize-Catalyst/trunk/t/lib
ash at dev.catalyst.perl.org
ash at dev.catalyst.perl.org
Mon Feb 2 20:10:59 GMT 2009
Author: ash
Date: 2009-02-02 20:10:59 +0000 (Mon, 02 Feb 2009)
New Revision: 9164
Added:
Test-WWW-Mechanize-Catalyst/
Test-WWW-Mechanize-Catalyst/branches/
Test-WWW-Mechanize-Catalyst/branchs/
Test-WWW-Mechanize-Catalyst/tags/
Test-WWW-Mechanize-Catalyst/trunk/
Test-WWW-Mechanize-Catalyst/trunk/CHANGES
Test-WWW-Mechanize-Catalyst/trunk/MANIFEST.SKIP
Test-WWW-Mechanize-Catalyst/trunk/Makefile.PL
Test-WWW-Mechanize-Catalyst/trunk/lib/
Test-WWW-Mechanize-Catalyst/trunk/lib/Test/
Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/
Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/
Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm
Test-WWW-Mechanize-Catalyst/trunk/t/
Test-WWW-Mechanize-Catalyst/trunk/t/auth-test.t
Test-WWW-Mechanize-Catalyst/trunk/t/cookies.t
Test-WWW-Mechanize-Catalyst/trunk/t/lib/
Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm
Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession.pm
Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm
Test-WWW-Mechanize-Catalyst/trunk/t/multi_content_type.t
Test-WWW-Mechanize-Catalyst/trunk/t/pod.t
Test-WWW-Mechanize-Catalyst/trunk/t/pod_coverage.t
Test-WWW-Mechanize-Catalyst/trunk/t/redirect.t
Test-WWW-Mechanize-Catalyst/trunk/t/simple.t
Log:
Commit latest CPAN ver of TWMC to repo
Added: Test-WWW-Mechanize-Catalyst/trunk/CHANGES
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/CHANGES (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/CHANGES 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,76 @@
+Revision history for Perl module Test::WWW::Mechanize::Catalyst:
+
+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
Added: Test-WWW-Mechanize-Catalyst/trunk/MANIFEST.SKIP
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/MANIFEST.SKIP (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/MANIFEST.SKIP 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,33 @@
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+,v$
+\B\.svn\b
+
+# Avoid Makemaker generated and utility files.
+\bMakefile$
+\bblib
+\bMakeMaker-\d
+\bpm_to_blib$
+\bblibdirs$
+^MANIFEST\.SKIP$
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\b_build
+
+# Avoid temp and backup files.
+~$
+\.tmp$
+\.old$
+\.bak$
+\.sw[op]$
+\#$
+\b\.#
+\.DS_Store$
+
+
+# No tarballs!
+\.gz$
+\.tar$
+
Added: Test-WWW-Mechanize-Catalyst/trunk/Makefile.PL
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/Makefile.PL (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/Makefile.PL 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,23 @@
+#!perl
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ 'NAME' => 'Test::WWW::Mechanize::Catalyst',
+ 'VERSION_FROM' => 'lib/Test/WWW/Mechanize/Catalyst.pm',
+ 'AUTHOR' => 'Leon Brocard <acme at astray.com>',
+ 'ABSTRACT' => 'Test::WWW::Mechanize for Catalyst',
+ 'LICENSE' => 'perl',
+ 'PREREQ_PM' => {
+ 'Catalyst' => '5.00',
+ 'Catalyst::Plugin::Session::State::Cookie' => '0',
+ 'Catalyst::Plugin::Session::Store::Dummy' => '0',
+ 'LWP' => '5.816',
+ 'Test::Exception' => '0',
+ 'Test::More' => '0',
+ 'Test::WWW::Mechanize' => '1.14',
+ 'WWW::Mechanize' => '1.50',
+ },
+);
+
Added: Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/lib/Test/WWW/Mechanize/Catalyst.pm 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,369 @@
+package Test::WWW::Mechanize::Catalyst;
+use strict;
+use warnings;
+use Encode qw();
+use HTML::Entities;
+use Test::WWW::Mechanize;
+use base qw(Test::WWW::Mechanize);
+our $VERSION = '0.45';
+my $Test = Test::Builder->new();
+
+# the reason for the auxiliary package is that both WWW::Mechanize and
+# Catalyst::Test have a subroutine named 'request'
+
+sub allow_external {
+ my ( $self, $value ) = @_;
+ return $self->{allow_external} unless defined $value;
+ $self->{allow_external} = $value;
+}
+
+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);
+ }
+ }
+
+ $request->authorization_basic(
+ LWP::UserAgent->get_basic_credentials(
+ undef, "Basic", $request->uri
+ )
+ )
+ if LWP::UserAgent->get_basic_credentials( undef, "Basic",
+ $request->uri );
+
+ my $response = Test::WWW::Mechanize::Catalyst::Aux::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 ) );
+ }
+ $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')
+ && $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 import {
+ Test::WWW::Mechanize::Catalyst::Aux::import(@_);
+}
+
+package Test::WWW::Mechanize::Catalyst::Aux;
+
+sub import {
+ my ( $class, @args ) = @_;
+ eval {
+ require Catalyst::Test;
+ Catalyst::Test::import(@_);
+ };
+ warn $@ if $@;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
+
+=head1 SYNOPSIS
+
+ # We're in a t/*.t test script...
+ # To test a Catalyst application named 'Catty':
+ use Test::WWW::Mechanize::Catalyst '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
+
+=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.
+
+Testing web applications has always been a bit tricky, normally
+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
+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:
+
+ $m->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.
+
+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 developing 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;
+
+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 parms
+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:
+
+ $m->allow_external(1);
+
+=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 matches 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 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 parms to pass to C<follow_link()>.
+Note that the parms 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" );
+
+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 SEE ALSO
+
+Related modules which may be of interest: L<Catalyst>,
+L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
+
+=head1 AUTHOR
+
+Leon Brocard, C<< <acme at astray.com> >>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-7, Leon Brocard
+
+=head1 LICENSE
+
+This module is free software; you can redistribute it or modify it
+under the same terms as Perl itself.
+
Added: Test-WWW-Mechanize-Catalyst/trunk/t/auth-test.t
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/auth-test.t (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/auth-test.t 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,23 @@
+#!perl -T
+use strict;
+use warnings;
+use lib 'lib';
+use Test::More tests => 5;
+use lib 't/lib';
+use Test::WWW::Mechanize::Catalyst 'Catty';
+
+my $root = "http://localhost";
+
+my $m = Test::WWW::Mechanize::Catalyst->new( autocheck => 0 );
+$m->credentials( 'user', 'pass' );
+
+$m->get_ok("$root/check_auth_basic/");
+is( $m->ct, "text/html" );
+is( $m->status, 200 );
+
+$m->credentials( 'boofar', 'pass' );
+
+$m->get("$root/check_auth_basic/");
+is( $m->ct, "text/html" );
+is( $m->status, 401 );
+
Added: Test-WWW-Mechanize-Catalyst/trunk/t/cookies.t
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/cookies.t (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/cookies.t 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,27 @@
+#!perl -T
+use strict;
+use warnings;
+use lib 'lib';
+use Test::More;
+
+eval {
+ require Catalyst::Plugin::Session;
+ require Catalyst::Plugin::Session::State::Cookie;
+};
+
+if ($@) {
+ diag($@);
+ plan skip_all => "Need Catalyst::Plugin::Session to run this test";
+} else {
+ plan tests => 3;
+}
+use lib 't/lib';
+use Test::WWW::Mechanize::Catalyst 'CattySession';
+
+my $m = Test::WWW::Mechanize::Catalyst->new;
+$m->credentials( 'user', 'pass' );
+
+$m->get_ok("/");
+$m->title_is("Root");
+
+is( $m->status, 200 );
Added: Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/lib/Catty.pm 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,112 @@
+package Catty;
+
+use strict;
+
+#use Catalyst;
+use Catalyst qw/-Debug/;
+use Cwd;
+use MIME::Base64;
+
+our $VERSION = '0.01';
+
+Catty->config(
+ name => 'Catty',
+ root => cwd . '/t/root',
+);
+
+Catty->setup();
+
+sub default : Private {
+ my ( $self, $context ) = @_;
+ my $html = html( "Root", "This is the root page" );
+ $context->response->content_type("text/html");
+ $context->response->output($html);
+}
+
+sub hello : Global {
+ my ( $self, $context ) = @_;
+ my $html = html( "Hello", "Hi there! ☺" );
+ $context->response->content_type("text/html; charset=utf-8");
+ $context->response->output($html);
+}
+
+# absolute redirect
+sub hi : Global {
+ my ( $self, $context ) = @_;
+ my $where = $context->uri_for('hello');
+ $context->response->redirect($where);
+ return;
+}
+
+# partial (relative) redirect
+sub greetings : Global {
+ my ( $self, $context ) = @_;
+ $context->response->redirect("hello");
+ return;
+}
+
+# redirect to a redirect
+sub bonjour : Global {
+ my ( $self, $context ) = @_;
+ my $where = $context->uri_for('hi');
+ $context->response->redirect($where);
+ return;
+}
+
+sub check_auth_basic : Global {
+ my ( $self, $context ) = @_;
+
+ my $auth = $context->req->headers->authorization;
+ ($auth) = $auth =~ /Basic\s(.*)/i;
+ $auth = decode_base64($auth);
+
+ if ( $auth eq "user:pass" ) {
+ my $html = html( "Auth", "This is the auth page" );
+ $context->response->content_type("text/html");
+ $context->response->output($html);
+ return $context;
+ } else {
+ my $html = html( "Auth", "Auth Failed!" );
+ $context->response->content_type("text/html");
+ $context->response->output($html);
+ $context->response->status("401");
+ return $context;
+ }
+}
+
+sub die : Global {
+ my ( $self, $context ) = @_;
+ my $html = html( "Die", "This is the die page" );
+ $context->response->content_type("text/html");
+ $context->response->output($html);
+ die "erk!";
+}
+
+sub html {
+ my ( $title, $body ) = @_;
+ return qq{
+<html>
+<head><title>$title</title></head>
+<body>
+$body
+<a href="/hello/">Hello</a>.
+</body></html>
+};
+}
+
+sub gzipped : Global {
+ my ( $self, $c ) = @_;
+
+ # If done properly this test should check the accept-encoding header, but we
+ # control both ends, so just always gzip the response.
+ require Compress::Zlib;
+
+ my $html = html( "Hello", "Hi there! ☺" );
+ $c->response->content_type("text/html; charset=utf-8");
+ $c->response->output( Compress::Zlib::memGzip($html) );
+ $c->response->content_encoding('gzip');
+ $c->response->headers->push_header( 'Vary', 'Accept-Encoding' );
+}
+
+1;
+
Added: Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession.pm (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/lib/CattySession.pm 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,51 @@
+package CattySession;
+
+use strict;
+
+#use Catalyst;
+use Catalyst qw/-Debug
+ Session
+ Session::State::Cookie
+ Session::Store::Dummy
+ /;
+use Cwd;
+use MIME::Base64;
+
+our $VERSION = '0.01';
+
+CattySession->config(
+ name => 'CattySession',
+ root => cwd . '/t/root',
+);
+
+CattySession->setup();
+
+sub auto : Private {
+ my ( $self, $context ) = @_;
+ if ( $context->session ) {
+ return 1;
+ }
+
+}
+
+sub default : Private {
+ my ( $self, $context ) = @_;
+ my $html = html( "Root", "This is the root page" );
+ $context->response->content_type("text/html");
+ $context->response->output($html);
+}
+
+sub html {
+ my ( $title, $body ) = @_;
+ return qq{
+<html>
+<head><title>$title</title></head>
+<body>
+$body
+<a href="/hello/">Hello</a>.
+</body></html>
+};
+}
+
+1;
+
Added: Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/lib/ExternalCatty.pm 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,47 @@
+package ExternalCatty;
+use strict;
+use warnings;
+use Catalyst qw/-Engine=HTTP/;
+our $VERSION = '0.01';
+
+__PACKAGE__->config( name => 'ExternalCatty' );
+__PACKAGE__->setup;
+
+sub default : Private {
+ my ( $self, $c ) = @_;
+ $c->response->content_type('text/html; charset=utf-8');
+ $c->response->output( html( 'Root', 'Hello, test ☺!' ) );
+}
+
+sub html {
+ my ( $title, $body ) = @_;
+ return qq[
+<html>
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+ <title>$title</title>
+</head>
+<body>$body</body>
+</html>
+];
+}
+
+# The Cat HTTP server background option is useless here :-(
+# Thus we have to provide our own background method.
+sub background {
+ my $self = shift;
+ my $port = shift;
+ my $child = fork;
+ die "Can't fork Cat HTTP server: $!" unless defined $child;
+ return $child if $child;
+
+ if ( $^O !~ /MSWin32/ ) {
+ require POSIX;
+ POSIX::setsid() or die "Can't start a new session: $!";
+ }
+
+ $self->run($port);
+}
+
+1;
+
Added: Test-WWW-Mechanize-Catalyst/trunk/t/multi_content_type.t
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/multi_content_type.t (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/multi_content_type.t 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,49 @@
+#!perl
+use strict;
+use warnings;
+use lib qw(lib t/lib);
+
+my $PORT;
+
+BEGIN {
+ $PORT = $ENV{TWMC_TEST_PORT} || 7357;
+ $ENV{CATALYST_SERVER} ||= "http://localhost:$PORT";
+}
+
+use Test::More tests => 6;
+use Test::Exception;
+
+BEGIN {
+ diag(
+ "###################################################################\n",
+ "Starting an external Catalyst HTTP server on port $PORT\n",
+ "To change the port, please set the TWMC_TEST_PORT env variable.\n",
+ "(The server will be automatically shut-down right after the tests).\n",
+ "###################################################################\n"
+ );
+}
+
+# Let's catch interrupts to force the END block execution.
+$SIG{INT} = sub { warn "INT:$$"; exit };
+
+use_ok 'ExternalCatty';
+my $pid = ExternalCatty->background($PORT);
+
+use Test::WWW::Mechanize::Catalyst 'ExternalCatty';
+my $m = Test::WWW::Mechanize::Catalyst->new;
+
+lives_ok { $m->get_ok( '/', 'Get a multi Content-Type response' ) }
+'Survive to a multi Content-Type sting';
+
+is( $m->ct, 'text/html', 'Multi Content-Type Content-Type' );
+$m->title_is( 'Root', 'Multi Content-Type title' );
+$m->content_contains( "Hello, test \x{263A}!", 'Multi Content-Type body' );
+
+END {
+ if ( $pid > 0 ) {
+ kill 9, $pid;
+ }
+}
+
+1;
+
Added: Test-WWW-Mechanize-Catalyst/trunk/t/pod.t
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/pod.t (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/pod.t 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD: $@" if $@;
+all_pod_files_ok();
Added: Test-WWW-Mechanize-Catalyst/trunk/t/pod_coverage.t
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/pod_coverage.t (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/pod_coverage.t 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,7 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage"
+ if $@;
+all_pod_coverage_ok();
Added: Test-WWW-Mechanize-Catalyst/trunk/t/redirect.t
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/redirect.t (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/redirect.t 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,32 @@
+#!perl -T
+use strict;
+use warnings;
+use lib 'lib';
+use Test::More tests => 27;
+use lib 't/lib';
+use Test::WWW::Mechanize::Catalyst 'Catty';
+
+my $root = "http://localhost";
+
+my $m;
+foreach my $where (qw{hi greetings bonjour}) {
+ $m = Test::WWW::Mechanize::Catalyst->new;
+ $m->get_ok( "$root/$where", "got something when we $where" );
+
+ is( $m->base, "http://localhost/hello", "check got to hello 1/4" );
+ is( $m->ct, "text/html", "check got to hello 2/4" );
+ $m->title_is( "Hello",, "check got to hello 3/4" );
+ $m->content_contains( "Hi there",, "check got to hello 4/4" );
+
+ # check that the previous response is still there
+ my $prev = $m->response->previous;
+ ok( $prev, "have a previous" );
+ is( $prev->code, 302, "was a redirect" );
+ like( $prev->header('Location'), '/hello$/', "to the right place" );
+}
+
+# extra checks for bonjour (which is a double redirect)
+my $prev = $m->response->previous->previous;
+ok( $prev, "have a previous previous" );
+is( $prev->code, 302, "was a redirect" );
+like( $prev->header('Location'), '/hi$/', "to the right place" );
Added: Test-WWW-Mechanize-Catalyst/trunk/t/simple.t
===================================================================
--- Test-WWW-Mechanize-Catalyst/trunk/t/simple.t (rev 0)
+++ Test-WWW-Mechanize-Catalyst/trunk/t/simple.t 2009-02-02 20:10:59 UTC (rev 9164)
@@ -0,0 +1,73 @@
+#!perl -T
+use strict;
+use warnings;
+use lib 'lib';
+use Encode qw();
+use Test::More tests => 39;
+use lib 't/lib';
+use Test::WWW::Mechanize::Catalyst 'Catty';
+
+my $root = "http://localhost";
+
+my $m = Test::WWW::Mechanize::Catalyst->new( autocheck => 0 );
+
+$m->get_ok("$root/");
+is( $m->ct, "text/html" );
+$m->title_is("Root");
+$m->content_contains("This is the root page");
+
+$m->follow_link_ok( { text => 'Hello' } );
+is( $m->base, "http://localhost/hello/" );
+is( $m->ct, "text/html" );
+$m->title_is("Hello");
+$m->content_contains( Encode::decode( 'utf-8', "Hi there! ☺" ) );
+
+#use Devel::Peek; Dump $m->content;
+#Dump(Encode::decode('utf-8', "Hi there! ☺"));
+#exit;
+
+$m->get_ok("/");
+is( $m->ct, "text/html" );
+$m->title_is("Root");
+$m->content_contains("This is the root page");
+
+$m->get_ok("http://example.com/");
+is( $m->ct, "text/html" );
+$m->title_is("Root");
+$m->content_contains("This is the root page");
+
+$m->get_ok("/hello/");
+is( $m->ct, "text/html" );
+$m->title_is("Hello");
+$m->content_contains( Encode::decode( 'utf-8', "Hi there! ☺" ) );
+
+SKIP: {
+ eval { require Compress::Zlib; };
+ skip "Compress::Zlib needed to test gzip encoding", 4 if $@;
+ $m->get_ok("/gzipped/");
+ is( $m->ct, "text/html" );
+ $m->title_is("Hello");
+ $m->content_contains( Encode::decode( 'utf-8', "Hi there! ☺" ) );
+}
+
+$m->get("$root/die/");
+is( $m->status, 500 );
+is( $m->ct, "" );
+$m->title_is(undef);
+$m->content_is("");
+
+$m->get("/die/");
+is( $m->status, 500 );
+is( $m->ct, "" );
+$m->title_is(undef);
+$m->content_is("");
+
+$m->{catalyst_debug} = 1;
+$m->get("$root/die/");
+is( $m->status, 500 );
+is( $m->ct, "text/html" );
+$m->title_like(qr/Catty on Catalyst/);
+$m->content_like(qr/Caught exception in Catty/);
+$m->content_like(qr/erk/);
+$m->content_like(qr/This is the die page/);
+
More information about the Catalyst-commits
mailing list