From: Ash Berlin Date: Mon, 2 Feb 2009 20:10:59 +0000 (+0000) Subject: Commit latest CPAN ver of TWMC to repo X-Git-Tag: 0.51~17 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FTest-WWW-Mechanize-Catalyst.git;a=commitdiff_plain;h=6bc863629dfa3bec1d938eb5a7af7ef68fd3849f Commit latest CPAN ver of TWMC to repo --- 6bc863629dfa3bec1d938eb5a7af7ef68fd3849f diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..4bfc51a --- /dev/null +++ b/CHANGES @@ -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 diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..37e81eb --- /dev/null +++ b/MANIFEST.SKIP @@ -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$ + diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..61aa05e --- /dev/null +++ b/Makefile.PL @@ -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 ', + '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', + }, +); + diff --git a/lib/Test/WWW/Mechanize/Catalyst.pm b/lib/Test/WWW/Mechanize/Catalyst.pm new file mode 100644 index 0000000..f6964ce --- /dev/null +++ b/lib/Test/WWW/Mechanize/Catalyst.pm @@ -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>/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 is an elegant MVC Web Application +Framework. L is a subclass of L that +incorporates features for web application testing. The +L module meshes the two to allow easy +testing of L 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 web +applications but does not start a server or issue HTTP +requests. Instead, it passes the HTTP request object directly to +L. 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 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. + +=head1 CONSTRUCTOR + +=head2 new + +Behaves like, and calls, L's C 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 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 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 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 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 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 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. +Note that the parms to C 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, +L, L. + +=head1 AUTHOR + +Leon Brocard, C<< >> + +=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. + diff --git a/t/auth-test.t b/t/auth-test.t new file mode 100644 index 0000000..4d9068f --- /dev/null +++ b/t/auth-test.t @@ -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 ); + diff --git a/t/cookies.t b/t/cookies.t new file mode 100644 index 0000000..823adb6 --- /dev/null +++ b/t/cookies.t @@ -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 ); diff --git a/t/lib/Catty.pm b/t/lib/Catty.pm new file mode 100644 index 0000000..cdd1405 --- /dev/null +++ b/t/lib/Catty.pm @@ -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{ + +$title + +$body +Hello. + +}; +} + +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; + diff --git a/t/lib/CattySession.pm b/t/lib/CattySession.pm new file mode 100644 index 0000000..db1a4f5 --- /dev/null +++ b/t/lib/CattySession.pm @@ -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{ + +$title + +$body +Hello. + +}; +} + +1; + diff --git a/t/lib/ExternalCatty.pm b/t/lib/ExternalCatty.pm new file mode 100644 index 0000000..da573f2 --- /dev/null +++ b/t/lib/ExternalCatty.pm @@ -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[ + + + + $title + +$body + +]; +} + +# 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; + diff --git a/t/multi_content_type.t b/t/multi_content_type.t new file mode 100644 index 0000000..2748ebc --- /dev/null +++ b/t/multi_content_type.t @@ -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; + diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..5c3c791 --- /dev/null +++ b/t/pod.t @@ -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(); diff --git a/t/pod_coverage.t b/t/pod_coverage.t new file mode 100644 index 0000000..2ee90fa --- /dev/null +++ b/t/pod_coverage.t @@ -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(); diff --git a/t/redirect.t b/t/redirect.t new file mode 100644 index 0000000..d7e25d4 --- /dev/null +++ b/t/redirect.t @@ -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" ); diff --git a/t/simple.t b/t/simple.t new file mode 100644 index 0000000..8433a40 --- /dev/null +++ b/t/simple.t @@ -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/); +