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 my $build_exports = sub {
  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     my $ctx_request = sub {
  34         my $me = ref $self || $self;
  35
  36         ### throw an exception if ctx_request is being used against a remote
  37         ### server
  38         Catalyst::Exception->throw("$me only works with local requests, not remote")
  39             if $ENV{CATALYST_SERVER};
  40
  41         ### check explicitly for the class here, or the Cat->meta call will blow
  42         ### up in our face
  43         Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") unless $class;
  44
  45         ### place holder for $c after the request finishes; reset every time
  46         ### requests are done.
  47         my $ctx_closed_over;
  48
  49         ### hook into 'dispatch' -- the function gets called after all plugins
  50         ### have done their work, and it's an easy place to capture $c.
  51
  52         my $meta = Class::MOP::get_metaclass_by_name($class);
  53         $meta->make_mutable;
  54         $meta->add_after_method_modifier( "dispatch", sub {
  55             $ctx_closed_over = shift;
  56         });
  57         $meta->make_immutable( replace_constructor => 1 );
  58         Class::C3::reinitialize(); # Fixes RT#46459, I've failed to write a test for how/why, but it does.
  59         ### do the request; C::T::request will know about the class name, and
  60         ### we've already stopped it from doing remote requests above.
  61         my $res = $request->( @_ );
  62
  63         # Make sure not to leave a reference $ctx hanging around.
  64         # This means that the context will go out of scope as soon as the
  65         # caller disposes of it, rather than waiting till the next time
  66         # that ctx_request is called. This can be important if your $ctx
  67         # ends up with a reference to a shared resource or lock (for example)
  68         # which you want to clean up in test teardown - if the $ctx is still
  69         # closed over then you're stuffed...
  70         my $ctx = $ctx_closed_over;
  71         undef $ctx_closed_over;
  72
  73         ### return both values
  74         return ( $res, $ctx );
  75     };
  76
  77     return {
  78         request      => $request,
  79         get          => $get,
  80         ctx_request  => $ctx_request,
  81         content_like => sub {
  82             my $action = shift;
  83             return Test::More->builder->like($get->($action),@_);
  84         },
  85         action_ok => sub {
  86             my $action = shift;
  87             return Test::More->builder->ok($request->($action)->is_success,@_ || "a route handler is defined for $action");
  88         },
  89         action_redirect => sub {
  90             my $action = shift;
  91             return Test::More->builder->ok($request->($action)->is_redirect,@_ || "a route handler redirects for $action");
  92         },
  93         action_notfound => sub {
  94             my $action = shift;
  95             return Test::More->builder->is_eq($request->($action)->code,404,@_ || "a route handler is not defined for $action");
  96         },
  97         contenttype_is => sub {
  98             my $action = shift;
  99             my $res = $request->($action);
 100             return Test::More->builder->is_eq(scalar($res->content_type),@_);
 101         },
 102     };
 103 };
 104
 105 our $default_host;
 106
 107 {
 108     my $import = Sub::Exporter::build_exporter({
 109         groups => [ all => $build_exports ],
 110         into_level => 1,
 111     });
 112
 113
 114     sub import {
 115         my ($self, $class, $opts) = @_;
 116         Carp::carp(
 117 qq{Importing Catalyst::Test without an application name is deprecated:\n
 118 Instead of saying: use Catalyst::Test;
 119 say: use Catalyst::Test (); # If you don't want to import a test app right now.
 120 or say: use Catalyst::Test 'MyApp'; # If you do want to import a test app.\n\n})
 121         unless $class;
 122         $import->($self, '-all' => { class => $class });
 123         $opts = {} unless ref $opts eq 'HASH';
 124         $default_host = $opts->{default_host} if exists $opts->{default_host};
 125         return 1;
 126     }
 127 }
 128
 129 =head1 NAME
 130
 131 Catalyst::Test - Test Catalyst Applications
 132
 133 =head1 SYNOPSIS
 134
 135     # Helper
 136     script/test.pl
 137
 138     # Tests
 139     use Catalyst::Test 'TestApp';
 140     my $content  = get('index.html');           # Content as string
 141     my $response = request('index.html');       # HTTP::Response object
 142     my($res, $c) = ctx_request('index.html');      # HTTP::Response & context object
 143
 144     use HTTP::Request::Common;
 145     my $response = request POST '/foo', [
 146         bar => 'baz',
 147         something => 'else'
 148     ];
 149
 150     # Run tests against a remote server
 151     CATALYST_SERVER='http://localhost:3000/' prove -r -l lib/ t/
 152
 153     use Catalyst::Test 'TestApp';
 154     use Test::More tests => 1;
 155
 156     ok( get('/foo') =~ /bar/ );
 157
 158     # mock virtual hosts
 159     use Catalyst::Test 'MyApp', { default_host => 'myapp.com' };
 160     like( get('/whichhost'), qr/served by myapp.com/ );
 161     like( get( '/whichhost', { host => 'yourapp.com' } ), qr/served by yourapp.com/ );
 162     {
 163         local $Catalyst::Test::default_host = 'otherapp.com';
 164         like( get('/whichhost'), qr/served by otherapp.com/ );
 165     }
 166
 167 =head1 DESCRIPTION
 168
 169 This module allows you to make requests to a Catalyst application either without
 170 a server, by simulating the environment of an HTTP request using
 171 L<HTTP::Request::AsCGI> or remotely if you define the CATALYST_SERVER
 172 environment variable. This module also adds a few Catalyst-specific
 173 testing methods as displayed in the method section.
 174
 175 The L<get|/"$content = get( ... )"> and L<request|/"$res = request( ... );">
 176 functions take either a URI or an L<HTTP::Request> object.
 177
 178 =head1 INLINE TESTS WILL NO LONGER WORK
 179
 180 While it used to be possible to inline a whole testapp into a C<.t> file for a
 181 distribution, this will no longer work.
 182
 183 The convention is to place your L<Catalyst> test apps into C<t/lib> in your
 184 distribution. E.g.: C<t/lib/TestApp.pm>, C<t/lib/TestApp/Controller/Root.pm>,
 185 etc..  Multiple test apps can be used in this way.
 186
 187 Then write your C<.t> files like so:
 188
 189     use strict;
 190     use warnings;
 191     use FindBin '$Bin';
 192     use lib "$Bin/lib";
 193     use Test::More tests => 6;
 194     use Catalyst::Test 'TestApp';
 195
 196 =head1 METHODS
 197
 198 =head2 $content = get( ... )
 199
 200 Returns the content.
 201
 202     my $content = get('foo/bar?test=1');
 203
 204 Note that this method doesn't follow redirects, so to test for a
 205 correctly redirecting page you'll need to use a combination of this
 206 method and the L<request|/"$res = request( ... );"> method below:
 207
 208     my $res = request('/'); # redirects to /y
 209     warn $res->header('location');
 210     use URI;
 211     my $uri = URI->new($res->header('location'));
 212     is ( $uri->path , '/y');
 213     my $content = get($uri->path);
 214
 215 Note also that the content is returned as raw bytes, without any attempt
 216 to decode it into characters.
 217
 218 =head2 $res = request( ... );
 219
 220 Returns an L<HTTP::Response> object. Accepts an optional hashref for request
 221 header configuration; currently only supports setting 'host' value.
 222
 223     my $res = request('foo/bar?test=1');
 224     my $virtual_res = request('foo/bar?test=1', {host => 'virtualhost.com'});
 225
 226 =head1 FUNCTIONS
 227
 228 =head2 ($res, $c) = ctx_request( ... );
 229
 230 Works exactly like L<request|/"$res = request( ... );">, except it also returns the Catalyst context object,
 231 C<$c>. Note that this only works for local requests.
 232
 233 =head2 $res = Catalyst::Test::local_request( $AppClass, $url );
 234
 235 Simulate a request using L<HTTP::Request::AsCGI>.
 236
 237 =cut
 238
 239 sub local_request {
 240     my $class = shift;
 241
 242     require HTTP::Request::AsCGI;
 243
 244     my $request = Catalyst::Utils::request( shift(@_) );
 245     _customize_request($request, @_);
 246     my $cgi     = HTTP::Request::AsCGI->new( $request, %ENV )->setup;
 247
 248     $class->handle_request( env => \%ENV );
 249
 250     my $response = $cgi->restore->response;
 251     $response->request( $request );
 252
 253     # HTML head parsing based on LWP::UserAgent
 254
 255     require HTML::HeadParser;
 256
 257     my $parser = HTML::HeadParser->new();
 258     $parser->xml_mode(1) if $response->content_is_xhtml;
 259     $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
 260
 261     $parser->parse( $response->content );
 262     my $h = $parser->header;
 263     for my $f ( $h->header_field_names ) {
 264         $response->init_header( $f, [ $h->header($f) ] );
 265     }
 266
 267     return $response;
 268 }
 269
 270 my $agent;
 271
 272 =head2 $res = Catalyst::Test::remote_request( $url );
 273
 274 Do an actual remote request using LWP.
 275
 276 =cut
 277
 278 sub remote_request {
 279
 280     require LWP::UserAgent;
 281
 282     my $request = Catalyst::Utils::request( shift(@_) );
 283     my $server  = URI->new( $ENV{CATALYST_SERVER} );
 284
 285     _customize_request($request, @_);
 286
 287     if ( $server->path =~ m|^(.+)?/$| ) {
 288         my $path = $1;
 289         $server->path("$path") if $path;    # need to be quoted
 290     }
 291
 292     # the request path needs to be sanitised if $server is using a
 293     # non-root path due to potential overlap between request path and
 294     # response path.
 295     if ($server->path) {
 296         # If request path is '/', we have to add a trailing slash to the
 297         # final request URI
 298         my $add_trailing = $request->uri->path eq '/';
 299
 300         my @sp = split '/', $server->path;
 301         my @rp = split '/', $request->uri->path;
 302         shift @sp;shift @rp; # leading /
 303         if (@rp) {
 304             foreach my $sp (@sp) {
 305                 $sp eq $rp[0] ? shift @rp : last
 306             }
 307         }
 308         $request->uri->path(join '/', @rp);
 309
 310         if ( $add_trailing ) {
 311             $request->uri->path( $request->uri->path . '/' );
 312         }
 313     }
 314
 315     $request->uri->scheme( $server->scheme );
 316     $request->uri->host( $server->host );
 317     $request->uri->port( $server->port );
 318     $request->uri->path( $server->path . $request->uri->path );
 319
 320     unless ($agent) {
 321
 322         $agent = LWP::UserAgent->new(
 323             keep_alive   => 1,
 324             max_redirect => 0,
 325             timeout      => 60,
 326
 327             # work around newer LWP max_redirect 0 bug
 328             # http://rt.cpan.org/Ticket/Display.html?id=40260
 329             requests_redirectable => [],
 330         );
 331
 332         $agent->env_proxy;
 333     }
 334
 335     return $agent->request($request);
 336 }
 337
 338 sub _customize_request {
 339     my $request = shift;
 340     my $opts = pop(@_) || {};
 341     $opts = {} unless ref($opts) eq 'HASH';
 342     if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host  ) {
 343         $request->header( 'Host' => $host );
 344     }
 345 }
 346
 347 =head2 action_ok($url [, $test_name ])
 348
 349 Fetches the given URL and checks that the request was successful. An optional
 350 second argument can be given to specify the name of the test.
 351
 352 =head2 action_redirect($url [, $test_name ])
 353
 354 Fetches the given URL and checks that the request was a redirect. An optional
 355 second argument can be given to specify the name of the test.
 356
 357 =head2 action_notfound($url [, $test_name ])
 358
 359 Fetches the given URL and checks that the request was not found. An optional
 360 second argument can be given to specify the name of the test.
 361
 362 =head2 content_like( $url, $regexp [, $test_name ] )
 363
 364 Fetches the given URL and returns whether the content matches the regexp. An
 365 optional third argument can be given to specify the name of the test.
 366
 367 =head2 contenttype_is($url, $type [, $test_name ])
 368
 369 Verify the given URL has a content type of $type and optionally specify a test name.
 370
 371 =head1 SEE ALSO
 372
 373 L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
 374 L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common>
 375
 376 =head1 AUTHORS
 377
 378 Catalyst Contributors, see Catalyst.pm
 379
 380 =head1 COPYRIGHT
 381
 382 This library is free software. You can redistribute it and/or modify it under
 383 the same terms as Perl itself.
 384
 385 =cut
 386
 387 1;