From: Jos Boumans Date: Wed, 18 Mar 2009 16:34:44 +0000 (+0000) Subject: Add Catalyst::Test::crequest to return both HTTP::Response object & $c for X-Git-Tag: 5.71001~9 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=26dd6d9f6575fe782e78d6845fff3447e5ba5744 Add Catalyst::Test::crequest to return both HTTP::Response object & $c for local requests Add extensive tests for this, as well as the old Cat::Test methods (largely untested before) Update Cat::Test docs to reflect crequest Small doc tweaks in Cat::Test to improve readability --- diff --git a/lib/Catalyst/Test.pm b/lib/Catalyst/Test.pm index f3d4de3..d6f80c5 100644 --- a/lib/Catalyst/Test.pm +++ b/lib/Catalyst/Test.pm @@ -18,8 +18,9 @@ Catalyst::Test - Test Catalyst Applications # Tests use Catalyst::Test 'TestApp'; - request('index.html'); - get('index.html'); + my $content = get('index.html'); # Content as string + my $response = request('index.html'); # HTTP::Response object + my($res, $c) = crequest('index.html'); # HTTP::Response & context object use HTTP::Request::Common; my $response = request POST '/foo', [ @@ -61,7 +62,7 @@ object. =head2 METHODS -=head2 get +=head2 $content = get( ... ) Returns the content. @@ -78,12 +79,19 @@ method and the L method below: is ( $uri->path , '/y'); my $content = get($uri->path); -=head2 request +=head2 $res = request( ... ); Returns a C object. my $res = request('foo/bar?test=1'); +=head1 FUNCTIONS + +=head2 ($res, $c) = crequest( ... ); + +Works exactly like C, except it also returns the +catalyst context object, C<$c>. Note that this only works for local requests. + =cut sub import { @@ -110,11 +118,40 @@ sub import { no strict 'refs'; my $caller = caller(0); - *{"$caller\::request"} = $request; - *{"$caller\::get"} = $get; + + *{"$caller\::request"} = $request; + *{"$caller\::get"} = $get; + *{"$caller\::crequest"} = sub { + my $me = ref $self || $self; + + ### throw an exception if crequest is being used against a remote + ### server + Catalyst::Exception->throw("$me only works with local requests, not remote") + if $ENV{CATALYST_SERVER}; + + ### place holder for $c after the request finishes; reset every time + ### requests are done. + my $c; + + ### hook into 'dispatch' -- the function gets called after all plugins + ### have done their work, and it's an easy place to capture $c. + no warnings 'redefine'; + my $dispatch = Catalyst->can('dispatch'); + local *Catalyst::dispatch = sub { + $c = shift; + $dispatch->( $c, @_ ); + }; + + ### do the request; C::T::request will know about the class name, and + ### we've already stopped it from doing remote requests above. + my $res = $request->( @_ ); + + ### return both values + return ( $res, $c ); + }; } -=head2 local_request +=head2 $res = Catalyst::Test::local_request( $AppClass, $url ); Simulate a request using L. @@ -135,7 +172,7 @@ sub local_request { my $agent; -=head2 remote_request +=head2 $res = Catalyst::Test::remote_request( $url ); Do an actual remote request using LWP. diff --git a/t/unit_load_catalyst_test.t b/t/unit_load_catalyst_test.t index 0dbf8e3..aadcbe2 100644 --- a/t/unit_load_catalyst_test.t +++ b/t/unit_load_catalyst_test.t @@ -3,14 +3,87 @@ use strict; use warnings; -use Test::More; +use FindBin; +use lib "$FindBin::Bin/lib"; +use Test::More tests => 48; -plan tests => 3; -use_ok('Catalyst::Test'); +my $Class = 'Catalyst::Test'; +my $App = 'TestApp'; +my $Pkg = __PACKAGE__; +my $Url = 'http://localhost/'; +my $Content = "root index"; -eval "get('http://localhost')"; -isnt( $@, "", "get returns an error message with no app specified"); +my %Meth = ( + $Pkg => [qw|get request crequest|], # exported + $Class => [qw|local_request remote_request|], # not exported +); -eval "request('http://localhost')"; -isnt( $@, "", "request returns an error message with no app specified"); +### make sure we're not trying to connect to a remote host -- these are local tests +local $ENV{CATALYST_SERVER}; + +use_ok( $Class ); + +### check available methods +{ ### turn of redefine warnings, we'll get new subs exported + ### XXX 'no warnings' and 'local $^W' wont work as warnings are turned on in + ### test.pm, so trap them for now --kane + { local $SIG{__WARN__} = sub {}; + ok( $Class->import, "Argumentless import for methods only" ); + } + + while( my($class, $meths) = each %Meth ) { + for my $meth ( @$meths ) { SKIP: { + + ### method available? + can_ok( $class, $meth ); + + ### only for exported methods + skip "Error tests only for exported methods", 2 unless $class eq $Pkg; + + ### check error conditions + eval { $class->can($meth)->( $Url ) }; + ok( $@, " $meth without app gives error" ); + like( $@, qr/$Class/, + " Error filled with expected content for '$meth'" ); + } } + } +} + +### simple tests for exported methods +{ ### turn of redefine warnings, we'll get new subs exported + ### XXX 'no warnings' and 'local $^W' wont work as warnings are turned on in + ### test.pm, so trap them for now --kane + { local $SIG{__WARN__} = sub {}; + ok( $Class->import( $App ), + "Loading $Class for App $App" ); + } + + ### test exported methods again + for my $meth ( @{ $Meth{$Pkg} } ) { SKIP: { + + ### do a call, we should get a result and perhaps a $c if it's 'crequest'; + my ($res, $c) = eval { $Pkg->can($meth)->( $Url ) }; + + ok( 1, " Called $Pkg->$meth( $Url )" ); + ok( !$@, " No critical error $@" ); + ok( $res, " Result obtained" ); + + ### get the content as a string, to make sure we got what we expected + my $res_as_string = $meth eq 'get' ? $res : $res->content; + is( $res_as_string, $Content, + " Content as expected: $res_as_string" ); + + ### some tests for 'crequest' + skip "Context tests skipped for '$meth'", 6 unless $meth eq 'crequest'; + + ok( $c, " Context object returned" ); + isa_ok( $c, $App, " Object" ); + is( $c->request->uri, $Url, + " Url recorded in request" ); + is( $c->response->body, $Content, + " Content recorded in response" ); + ok( $c->stash, " Stash accessible" ); + ok( $c->action, " Action object accessible" ); + } } +}