File Coverage

lib/Test/WWW/Mechanize/Catalyst.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             package Test::WWW::Mechanize::Catalyst;
2              
3 7     7   144336 use Moose;
  0            
  0            
4              
5             use Carp qw/croak/;
6             require Catalyst::Test; # Do not call import
7             use Class::Load qw(load_class is_class_loaded);
8             use Encode qw();
9             use HTML::Entities;
10             use Test::WWW::Mechanize;
11              
12             extends 'Test::WWW::Mechanize', 'Moose::Object';
13              
14             #use namespace::clean -except => 'meta';
15              
16             our $VERSION = '0.60';
17             our $APP_CLASS;
18             my $Test = Test::Builder->new();
19              
20             has catalyst_app => (
21             is => 'ro',
22             predicate => 'has_catalyst_app',
23             );
24              
25             has allow_external => (
26             is => 'rw',
27             isa => 'Bool',
28             default => 0
29             );
30              
31             has host => (
32             is => 'rw',
33             isa => 'Str',
34             clearer => 'clear_host',
35             predicate => 'has_host',
36             );
37              
38             sub new {
39             my $class = shift;
40              
41             my $args = ref $_[0] ? $_[0] : { @_ };
42            
43             # Dont let LWP complain about options for our attributes
44             my %attr_options = map {
45             my $n = $_->init_arg;
46             defined $n && exists $args->{$n}
47             ? ( $n => delete $args->{$n} )
48             : ( );
49             } $class->meta->get_all_attributes;
50              
51             my $obj = $class->SUPER::new(%$args);
52             my $self = $class->meta->new_object(
53             __INSTANCE__ => $obj,
54             ($APP_CLASS ? (catalyst_app => $APP_CLASS) : () ),
55             %attr_options
56             );
57              
58             $self->BUILDALL;
59              
60              
61             return $self;
62             }
63              
64             sub BUILD {
65             my ($self) = @_;
66              
67             unless ($ENV{CATALYST_SERVER}) {
68             croak "catalyst_app attribute is required unless CATALYST_SERVER env variable is set"
69             unless $self->has_catalyst_app;
70             load_class($self->catalyst_app)
71             unless (is_class_loaded($self->catalyst_app));
72             }
73             }
74              
75             sub _make_request {
76             my ( $self, $request, $arg, $size, $previous) = @_;
77              
78             my $response = $self->_do_catalyst_request($request);
79             $response->header( 'Content-Base', $response->request->uri )
80             unless $response->header('Content-Base');
81              
82             $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;
83              
84             # fail tests under the Catalyst debug screen
85             if ( !$self->{catalyst_debug}
86             && $response->code == 500
87             && $response->content =~ /on Catalyst \d+\.\d+/ )
88             {
89             my ($error)
90             = ( $response->content =~ /<code class="error">(.*?)<\/code>/s );
91             $error ||= "unknown error";
92             decode_entities($error);
93             $Test->diag("Catalyst error screen: $error");
94             $response->content('');
95             $response->content_type('');
96             }
97              
98             # NOTE: cargo-culted redirect checking from LWP::UserAgent:
99             $response->previous($previous) if $previous;
100             my $redirects = defined $response->redirects ? $response->redirects : 0;
101             if ($redirects > 0 and $redirects >= $self->max_redirect) {
102             return $self->_redirect_loop_detected($response);
103             }
104              
105             # check if that was a redirect
106             if ( $response->header('Location')
107             && $response->is_redirect
108             && $self->redirect_ok( $request, $response ) )
109             {
110             return $self->_redirect_loop_detected($response) if $self->max_redirect <= 0;
111              
112             # TODO: this should probably create the request by cloning the original
113             # request and modifying it as LWP::UserAgent::request does. But for now...
114              
115             # *where* do they want us to redirect to?
116             my $location = $response->header('Location');
117              
118             # no-one *should* be returning non-absolute URLs, but if they
119             # are then we'd better cope with it. Let's create a new URI, using
120             # our request as the base.
121             my $uri = URI->new_abs( $location, $request->uri )->as_string;
122             my $referral = HTTP::Request->new( GET => $uri );
123             return $self->request( $referral, $arg, $size, $response );
124             } else {
125             $response->{_raw_content} = $response->content;
126             }
127              
128             return $response;
129             }
130              
131             sub _redirect_loop_detected {
132             my ( $self, $response ) = @_;
133             $response->header("Client-Warning" =>
134             "Redirect loop detected (max_redirect = " . $self->max_redirect . ")");
135             $response->{_raw_content} = $response->content;
136             return $response;
137             }
138              
139             sub _set_host_header {
140             my ( $self, $request ) = @_;
141             # If there's no Host header, set one.
142             unless ($request->header('Host')) {
143             my $host = $self->has_host
144             ? $self->host
145             : $request->uri->host;
146             $host .= ':'.$request->uri->_port if $request->uri->_port;
147             $request->header('Host', $host);
148             }
149             }
150              
151             sub _do_catalyst_request {
152             my ($self, $request) = @_;
153              
154             my $uri = $request->uri;
155             $uri->scheme('http') unless defined $uri->scheme;
156             $uri->host('localhost') unless defined $uri->host;
157              
158             $request = $self->prepare_request($request);
159             $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
160              
161             # Woe betide anyone who unsets CATALYST_SERVER
162             return $self->_do_remote_request($request)
163             if $ENV{CATALYST_SERVER};
164              
165             $self->_set_host_header($request);
166              
167             my $res = $self->_check_external_request($request);
168             return $res if $res;
169              
170             my @creds = $self->get_basic_credentials( "Basic", $uri );
171             $request->authorization_basic( @creds ) if @creds;
172              
173             require Catalyst;
174             my $response = $Catalyst::VERSION >= 5.89000 ?
175             Catalyst::Test::_local_request($self->{catalyst_app}, $request) :
176             Catalyst::Test::local_request($self->{catalyst_app}, $request);
177              
178              
179             # LWP would normally do this, but we don't get down that far.
180             $response->request($request);
181              
182             return $response
183             }
184              
185             sub _check_external_request {
186             my ($self, $request) = @_;
187              
188             # If there's no host then definitley not an external request.
189             $request->uri->can('host_port') or return;
190              
191             if ( $self->allow_external && $request->uri->host_port ne 'localhost:80' ) {
192             return $self->SUPER::_make_request($request);
193             }
194             return undef;
195             }
196              
197             sub _do_remote_request {
198             my ($self, $request) = @_;
199              
200             my $res = $self->_check_external_request($request);
201             return $res if $res;
202              
203             my $server = URI->new( $ENV{CATALYST_SERVER} );
204              
205             if ( $server->path =~ m|^(.+)?/$| ) {
206             my $path = $1;
207             $server->path("$path") if $path; # need to be quoted
208             }
209              
210             # the request path needs to be sanitised if $server is using a
211             # non-root path due to potential overlap between request path and
212             # response path.
213             if ($server->path) {
214             # If request path is '/', we have to add a trailing slash to the
215             # final request URI
216             my $add_trailing = $request->uri->path eq '/';
217            
218             my @sp = split '/', $server->path;
219             my @rp = split '/', $request->uri->path;
220             shift @sp;shift @rp; # leading /
221             if (@rp) {
222             foreach my $sp (@sp) {
223             $sp eq $rp[0] ? shift @rp : last
224             }
225             }
226             $request->uri->path(join '/', @rp);
227            
228             if ( $add_trailing ) {
229             $request->uri->path( $request->uri->path . '/' );
230             }
231             }
232              
233             $request->uri->scheme( $server->scheme );
234             $request->uri->host( $server->host );
235             $request->uri->port( $server->port );
236             $request->uri->path( $server->path . $request->uri->path );
237             $self->_set_host_header($request);
238             return $self->SUPER::_make_request($request);
239             }
240              
241             sub import {
242             my ($class, $app) = @_;
243              
244             if (defined $app) {
245             load_class($app)
246             unless (is_class_loaded($app));
247             $APP_CLASS = $app;
248             }
249              
250             }
251              
252              
253             1;
254              
255             __END__
256              
257             =head1 NAME
258              
259             Test::WWW::Mechanize::Catalyst - Test::WWW::Mechanize for Catalyst
260              
261             =head1 SYNOPSIS
262              
263             # We're in a t/*.t test script...
264             use Test::WWW::Mechanize::Catalyst;
265              
266             # To test a Catalyst application named 'Catty':
267             my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Catty');
268              
269             $mech->get_ok("/"); # no hostname needed
270             is($mech->ct, "text/html");
271             $mech->title_is("Root", "On the root page");
272             $mech->content_contains("This is the root page", "Correct content");
273             $mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
274             # ... and all other Test::WWW::Mechanize methods
275            
276             # White label site testing
277             $mech->host("foo.com");
278             $mech->get_ok("/");
279              
280             =head1 DESCRIPTION
281              
282             L<Catalyst> is an elegant MVC Web Application Framework.
283             L<Test::WWW::Mechanize> is a subclass of L<WWW::Mechanize> that incorporates
284             features for web application testing. The L<Test::WWW::Mechanize::Catalyst>
285             module meshes the two to allow easy testing of L<Catalyst> applications without
286             needing to start up a web server.
287              
288             Testing web applications has always been a bit tricky, normally
289             requiring starting a web server for your application and making real HTTP
290             requests to it. This module allows you to test L<Catalyst> web
291             applications but does not require a server or issue HTTP
292             requests. Instead, it passes the HTTP request object directly to
293             L<Catalyst>. Thus you do not need to use a real hostname:
294             "http://localhost/" will do. However, this is optional. The following
295             two lines of code do exactly the same thing:
296              
297             $mech->get_ok('/action');
298             $mech->get_ok('http://localhost/action');
299              
300             Links which do not begin with / or are not for localhost can be handled
301             as normal Web requests - this is handy if you have an external
302             single sign-on system. You must set allow_external to true for this:
303              
304             $mech->allow_external(1);
305              
306             You can also test a remote server by setting the environment variable
307             CATALYST_SERVER; for example:
308              
309             $ CATALYST_SERVER=http://example.com/myapp prove -l t
310              
311             will run the same tests on the application running at
312             http://example.com/myapp regardless of whether or not you specify
313             http:://localhost for Test::WWW::Mechanize::Catalyst.
314              
315             Furthermore, if you set CATALYST_SERVER, the server will be regarded
316             as a remote server even if your links point to localhost. Thus, you
317             can use Test::WWW::Mechanize::Catalyst to test your live webserver
318             running on your local machine, if you need to test aspects of your
319             deployment environment (for example, configuration options in an
320             http.conf file) instead of just the Catalyst request handling.
321            
322             This makes testing fast and easy. L<Test::WWW::Mechanize> provides
323             functions for common web testing scenarios. For example:
324              
325             $mech->get_ok( $page );
326             $mech->title_is( "Invoice Status", "Make sure we're on the invoice page" );
327             $mech->content_contains( "Andy Lester", "My name somewhere" );
328             $mech->content_like( qr/(cpan|perl)\.org/, "Link to perl.org or CPAN" );
329              
330             This module supports cookies automatically.
331              
332             To use this module you must pass it the name of the application. See
333             the SYNOPSIS above.
334              
335             Note that Catalyst has a special development feature: the debug
336             screen. By default this module will treat responses which are the
337             debug screen as failures. If you actually want to test debug screens,
338             please use:
339              
340             $mech->{catalyst_debug} = 1;
341              
342             An alternative to this module is L<Catalyst::Test>.
343              
344             =head1 CONSTRUCTOR
345              
346             =head2 new
347              
348             Behaves like, and calls, L<WWW::Mechanize>'s C<new> method. Any params
349             passed in get passed to WWW::Mechanize's constructor. Note that we
350             need to pass the name of the Catalyst application to the "use":
351              
352             use Test::WWW::Mechanize::Catalyst 'Catty';
353             my $mech = Test::WWW::Mechanize::Catalyst->new;
354              
355             =head1 METHODS
356              
357             =head2 allow_external
358              
359             Links which do not begin with / or are not for localhost can be handled
360             as normal Web requests - this is handy if you have an external
361             single sign-on system. You must set allow_external to true for this:
362              
363             $mech->allow_external(1);
364              
365             head2 catalyst_app
366              
367             The name of the Catalyst app which we are testing against. Read-only.
368              
369             =head2 host
370              
371             The host value to set the "Host:" HTTP header to, if none is present already in
372             the request. If not set (default) then Catalyst::Test will set this to
373             localhost:80
374              
375             =head2 clear_host
376              
377             Unset the host attribute.
378              
379             =head2 has_host
380              
381             Do we have a value set for the host attribute
382              
383             =head2 $mech->get_ok($url, [ \%LWP_options ,] $desc)
384              
385             A wrapper around WWW::Mechanize's get(), with similar options, except the
386             second argument needs to be a hash reference, not a hash. Returns true or
387             false.
388              
389             =head2 $mech->title_is( $str [, $desc ] )
390              
391             Tells if the title of the page is the given string.
392              
393             $mech->title_is( "Invoice Summary" );
394              
395             =head2 $mech->title_like( $regex [, $desc ] )
396              
397             Tells if the title of the page matches the given regex.
398              
399             $mech->title_like( qr/Invoices for (.+)/
400              
401             =head2 $mech->title_unlike( $regex [, $desc ] )
402              
403             Tells if the title of the page does NOT match the given regex.
404              
405             $mech->title_unlike( qr/Invoices for (.+)/
406              
407             =head2 $mech->content_is( $str [, $desc ] )
408              
409             Tells if the content of the page matches the given string.
410              
411             =head2 $mech->content_contains( $str [, $desc ] )
412              
413             Tells if the content of the page contains I<$str>.
414              
415             =head2 $mech->content_lacks( $str [, $desc ] )
416              
417             Tells if the content of the page lacks I<$str>.
418              
419             =head2 $mech->content_like( $regex [, $desc ] )
420              
421             Tells if the content of the page matches I<$regex>.
422              
423             =head2 $mech->content_unlike( $regex [, $desc ] )
424              
425             Tells if the content of the page does NOT match I<$regex>.
426              
427             =head2 $mech->page_links_ok( [ $desc ] )
428              
429             Follow all links on the current page and test for HTTP status 200
430              
431             $mech->page_links_ok('Check all links');
432              
433             =head2 $mech->page_links_content_like( $regex,[ $desc ] )
434              
435             Follow all links on the current page and test their contents for I<$regex>.
436              
437             $mech->page_links_content_like( qr/foo/,
438             'Check all links contain "foo"' );
439              
440             =head2 $mech->page_links_content_unlike( $regex,[ $desc ] )
441              
442             Follow all links on the current page and test their contents do not
443             contain the specified regex.
444              
445             $mech->page_links_content_unlike(qr/Restricted/,
446             'Check all links do not contain Restricted');
447              
448             =head2 $mech->links_ok( $links [, $desc ] )
449              
450             Check the current page for specified links and test for HTTP status
451             200. The links may be specified as a reference to an array containing
452             L<WWW::Mechanize::Link> objects, an array of URLs, or a scalar URL
453             name.
454              
455             my @links = $mech->find_all_links( url_regex => qr/cnn\.com$/ );
456             $mech->links_ok( \@links, 'Check all links for cnn.com' );
457              
458             my @links = qw( index.html search.html about.html );
459             $mech->links_ok( \@links, 'Check main links' );
460              
461             $mech->links_ok( 'index.html', 'Check link to index' );
462              
463             =head2 $mech->link_status_is( $links, $status [, $desc ] )
464              
465             Check the current page for specified links and test for HTTP status
466             passed. The links may be specified as a reference to an array
467             containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
468             scalar URL name.
469              
470             my @links = $mech->links();
471             $mech->link_status_is( \@links, 403,
472             'Check all links are restricted' );
473              
474             =head2 $mech->link_status_isnt( $links, $status [, $desc ] )
475              
476             Check the current page for specified links and test for HTTP status
477             passed. The links may be specified as a reference to an array
478             containing L<WWW::Mechanize::Link> objects, an array of URLs, or a
479             scalar URL name.
480              
481             my @links = $mech->links();
482             $mech->link_status_isnt( \@links, 404,
483             'Check all links are not 404' );
484              
485             =head2 $mech->link_content_like( $links, $regex [, $desc ] )
486              
487             Check the current page for specified links and test the content of
488             each against I<$regex>. The links may be specified as a reference to
489             an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
490             or a scalar URL name.
491              
492             my @links = $mech->links();
493             $mech->link_content_like( \@links, qr/Restricted/,
494             'Check all links are restricted' );
495              
496             =head2 $mech->link_content_unlike( $links, $regex [, $desc ] )
497              
498             Check the current page for specified links and test that the content of each
499             does not match I<$regex>. The links may be specified as a reference to
500             an array containing L<WWW::Mechanize::Link> objects, an array of URLs,
501             or a scalar URL name.
502              
503             my @links = $mech->links();
504             $mech->link_content_like( \@links, qr/Restricted/,
505             'Check all links are restricted' );
506              
507             =head2 follow_link_ok( \%parms [, $comment] )
508              
509             Makes a C<follow_link()> call and executes tests on the results.
510             The link must be found, and then followed successfully. Otherwise,
511             this test fails.
512              
513             I<%parms> is a hashref containing the params to pass to C<follow_link()>.
514             Note that the params to C<follow_link()> are a hash whereas the parms to
515             this function are a hashref. You have to call this function like:
516              
517             $agent->follow_link_ok( {n=>3}, "looking for 3rd link" );
518              
519             As with other test functions, C<$comment> is optional. If it is supplied
520             then it will display when running the test harness in verbose mode.
521              
522             Returns true value if the specified link was found and followed
523             successfully. The HTTP::Response object returned by follow_link()
524             is not available.
525              
526             =head1 CAVEATS
527              
528             =head2 External Redirects and allow_external
529              
530             If you use non-fully qualified urls in your test scripts (i.e. anything without
531             a host, such as C<< ->get_ok( "/foo") >> ) and your app redirects to an
532             external URL, expect to be bitten once you come back to your application's urls
533             (it will try to request them on the remote server). This is due to a limitation
534             in WWW::Mechanize.
535              
536             One workaround for this is that if you are expecting to redirect to an external
537             site, clone the TWMC object and use the cloned object for the external
538             redirect.
539              
540              
541             =head1 SEE ALSO
542              
543             Related modules which may be of interest: L<Catalyst>,
544             L<Test::WWW::Mechanize>, L<WWW::Mechanize>.
545              
546             =head1 AUTHOR
547              
548             Ash Berlin C<< <ash@cpan.org> >> (current maintainer)
549              
550             Original Author: Leon Brocard, C<< <acme@astray.com> >>
551              
552             =head1 COPYRIGHT
553              
554             Copyright (C) 2005-9, Leon Brocard
555              
556             =head1 LICENSE
557              
558             This module is free software; you can redistribute it or modify it
559             under the same terms as Perl itself.
560