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