lib/Catalyst/Test.pm

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