lib/Catalyst/Test.pm

   1 package Catalyst::Test;
   2
   3 use Test::More;
   4
   5 use Catalyst::Exception;
   6 use Catalyst::Utils;
   7 use Class::MOP;
   8 use Sub::Exporter;
   9
  10 sub build_exports {
  11     my ($self, $meth, $args, $defaults) = @_;
  12
  13     my $request;
  14     my $class = $args->{class};
  15
  16     if ( $ENV{CATALYST_SERVER} ) {
  17         $request = sub { remote_request(@_) };
  18     } elsif (! $class) {
  19         $request = sub { Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") };
  20     } else {
  21         unless (Class::MOP::is_class_loaded($class)) {
  22             Class::MOP::load_class($class);
  23         }
  24         $class->import;
  25
  26         $request = sub { local_request( $class, @_ ) };
  27     }
  28
  29     my $get = sub { $request->(@_)->content };
  30
  31     return {
  32         request => $request,
  33         get     => $get,
  34         content_like => sub {
  35             my $action = shift;
  36             return Test::More->builder->like($get->($action),@_);
  37         },
  38         action_ok => sub {
  39             my $action = shift;
  40             return Test::More->builder->ok($request->($action)->is_success, @_);
  41         },
  42         action_redirect => sub {
  43             my $action = shift;
  44             return Test::More->builder->ok($request->($action)->is_redirect,@_);
  45         },
  46         action_notfound => sub {
  47             my $action = shift;
  48             return Test::More->builder->is_eq($request->($action)->code,404,@_);
  49         },
  50         contenttype_is => sub {
  51             my $action = shift;
  52             my $res = $request->($action);
  53             return Test::More->builder->is_eq(scalar($res->content_type),@_);
  54         },
  55     };
  56 }
  57
  58 use namespace::clean;
  59
  60 {
  61     my $import = Sub::Exporter::build_exporter({
  62         groups => [ all => \&build_exports ],
  63         into_level => 1,
  64     });
  65
  66     sub import {
  67         my ($self, $class) = @_;
  68         $import->($self, '-all' => { class => $class });
  69     }
  70 }
  71
  72 =head1 NAME
  73
  74 Catalyst::Test - Test Catalyst Applications
  75
  76 =head1 SYNOPSIS
  77
  78     # Helper
  79     script/test.pl
  80
  81     # Tests
  82     use Catalyst::Test 'TestApp';
  83     request('index.html');
  84     get('index.html');
  85
  86     use HTTP::Request::Common;
  87     my $response = request POST '/foo', [
  88         bar => 'baz',
  89         something => 'else'
  90     ];
  91
  92     # Run tests against a remote server
  93     CATALYST_SERVER='http://localhost:3000/' prove -r -l lib/ t/
  94
  95     # Tests with inline apps need to use Catalyst::Engine::Test
  96     package TestApp;
  97
  98     use Catalyst;
  99
 100     sub foo : Global {
 101             my ( $self, $c ) = @_;
 102             $c->res->output('bar');
 103     }
 104
 105     __PACKAGE__->setup();
 106
 107     package main;
 108
 109     use Catalyst::Test 'TestApp';
 110     use Test::More tests => 1;
 111
 112     ok( get('/foo') =~ /bar/ );
 113
 114 =head1 DESCRIPTION
 115
 116 This module allows you to make requests to a Catalyst application either without
 117 a server, by simulating the environment of an HTTP request using
 118 L<HTTP::Request::AsCGI> or remotely if you define the CATALYST_SERVER
 119 environment variable. This module also adds a few catalyst
 120 specific testing methods as displayed in the method section.
 121
 122 The </get> and </request> functions take either a URI or an L<HTTP::Request>
 123 object.
 124
 125 =head2 METHODS
 126
 127 =head2 get
 128
 129 Returns the content.
 130
 131     my $content = get('foo/bar?test=1');
 132
 133 Note that this method doesn't follow redirects, so to test for a
 134 correctly redirecting page you'll need to use a combination of this
 135 method and the L<request> method below:
 136
 137     my $res = request('/'); # redirects to /y
 138     warn $res->header('location');
 139     use URI;
 140     my $uri = URI->new($res->header('location'));
 141     is ( $uri->path , '/y');
 142     my $content = get($uri->path);
 143
 144 =head2 request
 145
 146 Returns a C<HTTP::Response> object.
 147
 148     my $res = request('foo/bar?test=1');
 149
 150 =head2 local_request
 151
 152 Simulate a request using L<HTTP::Request::AsCGI>.
 153
 154 =cut
 155
 156 sub local_request {
 157     my $class = shift;
 158
 159     require HTTP::Request::AsCGI;
 160
 161     my $request = Catalyst::Utils::request( shift(@_) );
 162     my $cgi     = HTTP::Request::AsCGI->new( $request, %ENV )->setup;
 163
 164     $class->handle_request;
 165
 166     return $cgi->restore->response;
 167 }
 168
 169 my $agent;
 170
 171 =head2 remote_request
 172
 173 Do an actual remote request using LWP.
 174
 175 =cut
 176
 177 sub remote_request {
 178
 179     require LWP::UserAgent;
 180
 181     my $request = Catalyst::Utils::request( shift(@_) );
 182     my $server  = URI->new( $ENV{CATALYST_SERVER} );
 183
 184     if ( $server->path =~ m|^(.+)?/$| ) {
 185         my $path = $1;
 186         $server->path("$path") if $path;    # need to be quoted
 187     }
 188
 189     # the request path needs to be sanitised if $server is using a
 190     # non-root path due to potential overlap between request path and
 191     # response path.
 192     if ($server->path) {
 193         # If request path is '/', we have to add a trailing slash to the
 194         # final request URI
 195         my $add_trailing = $request->uri->path eq '/';
 196
 197         my @sp = split '/', $server->path;
 198         my @rp = split '/', $request->uri->path;
 199         shift @sp;shift @rp; # leading /
 200         if (@rp) {
 201             foreach my $sp (@sp) {
 202                 $sp eq $rp[0] ? shift @rp : last
 203             }
 204         }
 205         $request->uri->path(join '/', @rp);
 206
 207         if ( $add_trailing ) {
 208             $request->uri->path( $request->uri->path . '/' );
 209         }
 210     }
 211
 212     $request->uri->scheme( $server->scheme );
 213     $request->uri->host( $server->host );
 214     $request->uri->port( $server->port );
 215     $request->uri->path( $server->path . $request->uri->path );
 216
 217     unless ($agent) {
 218
 219         $agent = LWP::UserAgent->new(
 220             keep_alive   => 1,
 221             max_redirect => 0,
 222             timeout      => 60,
 223         );
 224
 225         $agent->env_proxy;
 226     }
 227
 228     return $agent->request($request);
 229 }
 230
 231 =head2 action_ok
 232
 233 Fetches the given url and check that the request was successful
 234
 235 =head2 action_redirect
 236
 237 Fetches the given url and check that the request was a redirect
 238
 239 =head2 action_notfound
 240
 241 Fetches the given url and check that the request was not found
 242
 243 =head2 content_like
 244
 245 Fetches the given url and matches the content against it.
 246
 247 =head2 contenttype_is
 248
 249 Check for given mime type
 250
 251 =head1 SEE ALSO
 252
 253 L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
 254 L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common>
 255
 256 =head1 AUTHORS
 257
 258 Catalyst Contributors, see Catalyst.pm
 259
 260 =head1 COPYRIGHT
 261
 262 This program is free software, you can redistribute it and/or modify it under
 263 the same terms as Perl itself.
 264
 265 =cut
 266
 267 1;