1
2package Test::WWW::Mechanize::CGIApp;
3
4use strict;
5use warnings;
6
7# TODO use Test::WWW::Mechanize;
8use base 'Test::WWW::Mechanize';
9
10use HTTP::Request::AsCGI;
11
12our $VERSION = "0.05";
13
14sub new {
15  my ($class, %cnf) = @_;
16  my $self;
17  my $app;
18
19  if (exists($cnf{app})) {
20    $app = delete $cnf{app};
21  }
22
23  $self = $class->SUPER::new(%cnf);
24
25  $self->app( $app ) if ($app);
26  return $self;
27}
28
29sub app {
30  my $self = shift;
31
32  if (@_) {
33    $self->{_app} = shift;
34  }
35  return $self->{_app};
36}
37
38# copied from Test::WWW:Mechanize::Catalyst and slightly localized.
39sub _make_request {
40    my ( $self, $request ) = @_;
41    $request = _cleanup_request($request);
42    $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar;
43
44    my $response = $self->_do_request( $request );
45
46    $response->header( 'Content-Base', $request->uri );
47    $response->request($request);
48    $self->cookie_jar->extract_cookies($response) if $self->cookie_jar;
49
50    # check if that was a redirect
51    if (   $response->header('Location')
52        && $self->redirect_ok( $request, $response ) )
53      {
54
55        # remember the old response
56        my $old_response = $response;
57
58        # *where* do they want us to redirect to?
59        my $location = $old_response->header('Location');
60
61        # no-one *should* be returning non-absolute URLs, but if they
62        # are then we'd better cope with it.  Let's create a new URI, using
63        # our request as the base.
64        my $uri = URI->new_abs( $location, $request->uri )->as_string;
65
66        # make a new response, and save the old response in it
67        $response = $self->_make_request( HTTP::Request->new( GET => $uri ) );
68        my $end_of_chain = $response;
69        while ( $end_of_chain->previous )    # keep going till the end
70	  {
71            $end_of_chain = $end_of_chain->previous;
72	  }                                          #   of the chain...
73        $end_of_chain->previous($old_response);    # ...and add us to it
74      }
75
76    return $response;
77  }
78
79sub _cleanup_request {
80  my $request = shift;
81
82  $request->uri('http://localhost' . $request->uri())
83    unless ( $request->uri() =~ m|^http| );
84
85  return($request);
86}
87
88sub _do_request {
89  my $self = shift;
90  my $request = shift;
91
92  my $cgi = HTTP::Request::AsCGI->new($request, %ENV)->setup;
93  my $app = $self->app();
94
95  if (defined ($app)) {
96    if (ref $app) {
97      if (ref $app eq 'CODE') {
98	&{$app};
99      }
100      else {
101	die "The app value is a ref to something that isn't implemented.";
102      }
103    }
104    else {
105      # use eval since the module name isn't a BAREWORD
106      eval "require " . $app;
107
108      if ($app->isa("CGI::Application::Dispatch")) {
109	$app->dispatch();
110      }
111      elsif ($app->isa("CGI::Application")) {
112	my $app = $app->new();
113	$app->run();
114      }
115      else {
116	die "Unable to use the value of app.";
117      }
118    }
119  }
120  else {
121    die "App was not defined.";
122  }
123
124  return $cgi->restore->response;
125}
126
127
1281;
129
130__END__
131
132=pod
133
134=head1 NAME
135
136Test::WWW::Mechanize::CGIApp - Test::WWW::Mechanize for CGI::Application
137
138=head1 SYNOPSIS
139
140  # We're in a t/*.t test script...
141  use Test::WWW::Mechanize::CGIApp;
142
143  my $mech = Test::WWW::Mechanize::CGIApp->new;
144
145  # test a class that uses CGI::Application calling semantics.
146  # (in this case we'll new up an instance of the app and call
147  # its ->run() method)
148  #
149  $mech->app("My::WebApp");
150  $mech->get_ok("?rm=my_run_mode&arg1=1&arg2=42");
151
152  # test a class that uses CGI::Application::Dispatch
153  # to locate the run_mode
154  # (in this case we'll just call the ->dispatch() class method).
155  #
156  my $dispatched_mech = Test::WWW::Mechanize::CGIApp->new;
157  $dispatched_mech->app("My::DispatchApp");
158  $mech->get_ok("/WebApp/my_run_mode?arg1=1&arg2=42");
159
160  # create an anonymous sub that this class will use to
161  # handle the request.
162  #
163  # this could be useful if you need to do something novel
164  # after creating an instance of your class (e.g. the
165  # fiddle_with_stuff() below) or maybe you have a unique
166  # way to get the app to run.
167  #
168  my $custom_mech = Test::WWW::Mechanize::CGIApp->new;
169  $custom_mech->app(
170     sub {
171       require "My::WebApp";
172       my $app = My::WebApp->new();
173       $app->fiddle_with_stuff();
174       $app->run();
175     });
176  $mech->get_ok("?rm=my_run_mode&arg1=1&arg2=42");
177
178  # at this point you can play with all kinds of cool
179  # Test::WWW::Mechanize testing methods.
180  is($mech->ct, "text/html");
181  $mech->title_is("Root", "On the root page");
182  $mech->content_contains("This is the root page", "Correct content");
183  $mech->follow_link_ok({text => 'Hello'}, "Click on Hello");
184  # ... and all other Test::WWW::Mechanize methods
185
186=head1 DESCRIPTION
187
188This package makes testing CGIApp based modules fast and easy.  It takes
189advantage of L<Test::WWW::Mechanize> to provide functions for common
190web testing scenarios. For example:
191
192  $mech->get_ok( $page );
193  $mech->title_is( "Invoice Status",
194                   "Make sure we're on the invoice page" );
195  $mech->content_contains( "Andy Lester", "My name somewhere" );
196  $mech->content_like( qr/(cpan|perl)\.org/,
197                      "Link to perl.org or CPAN" );
198
199For applications that inherit from CGI::Application it will handle
200requests by creating a new instance of the class and calling its
201C<run> method.  For applications that use CGI::Application::Dispatch
202it will call the C<dispatch> class method.  If neither of these
203options are the right thing, you can set a reference to a sub that
204will be used to handle the request.
205
206This module supports cookies automatically.
207
208Check out L<Test::WWW::Mechanize> for more information about all of
209the cool things you can test!
210
211=head1 CONSTRUCTOR
212
213=head2 new
214
215Behaves like, and calls, L<Test::WWW::Mechanize>'s C<new> method.  It
216optionally uses an "app" parameter (see below), any other
217parameters get passed to Test::WWW::Mechanize's constructor. Note
218that you can either pass the name of the CGI::Application into the
219constructor using the "app" parameter or set it later using the C<app>
220method.
221
222  use Test::WWW::Mechanize::CGIApp;
223  my $mech = Test::WWW::Mechanize::CGIApp->new;
224
225  # or
226
227  my $mech = Test::WWW::Mechanize::CGIApp->new(app => 'TestApp');
228
229=head1 METHODS
230
231=head2 $mech->app($app_handler)
232
233This method provides a mechanism for informing
234Test::WWW::Mechanize::CGIApp how it should go about executing your
235run_mode.  If you set it to the name of a class, then it will load the
236class and either create an instance and ->run() it (if it's
237CGI::Application based), invoke the ->dispatch() method if it's
238CGI::Application::Dispatch based, or call the supplied anonymous
239subroutine and let it do all of the heavy lifting.
240
241=head1 SEE ALSO
242
243Related modules which may be of interest: L<Test::WWW::Mechanize>,
244L<WWW::Mechanize>.
245
246Various implementation tricks came from
247L<Test::WWW::Mechanize::Catalyst>.
248
249=head1 AUTHOR
250
251George Hartzell, C<< <hartzell@alerce.com> >>
252
253based on L<Test::WWW::Mechanize::Catalyst> by Leon Brocard, C<< <acme@astray.com> >>.
254
255=head1 COPYRIGHT
256
257Copyright (C) 2007, George Hartzell
258
259This module is free software; you can redistribute it or modify it
260under the same terms as Perl itself.
261