lib/Catalyst/Test.pm

   1 package Catalyst::Test;
   2
   3 use strict;
   4 use warnings;
   5 use Test::More ();
   6
   7 use Plack::Test;
   8 use Catalyst::Exception;
   9 use Catalyst::Utils;
  10 use Class::Load qw(load_class is_class_loaded);
  11 use Sub::Exporter;
  12 use Moose::Util 'find_meta';
  13 use Carp 'croak', 'carp';
  14
  15 sub _build_request_export {
  16     my ($self, $args) = @_;
  17
  18     return sub { _remote_request(@_) }
  19         if $args->{remote};
  20
  21     my $class = $args->{class};
  22
  23     # Here we should be failing right away, but for some stupid backcompat thing
  24     # I don't quite remember we fail lazily here. Needs a proper deprecation and
  25     # then removal.
  26     return sub { croak "Must specify a test app: use Catalyst::Test 'TestApp'" }
  27         unless $class;
  28
  29     load_class($class) unless is_class_loaded($class);
  30     $class->import;
  31
  32     return sub { _local_request( $class, @_ ) };
  33 }
  34
  35 sub _build_get_export {
  36     my ($self, $args) = @_;
  37     my $request = $args->{request};
  38
  39     return sub { $request->(@_)->content };
  40 }
  41 sub _build_ctx_request_export {
  42     my ($self, $args) = @_;
  43     my ($class, $request) = @{ $args }{qw(class request)};
  44
  45     return sub {
  46         my $me = ref $self || $self;
  47
  48         # fail if ctx_request is being used against a remote server
  49         Catalyst::Exception->throw("$me only works with local requests, not remote")
  50             if $ENV{CATALYST_SERVER};
  51
  52         # check explicitly for the class here, or the Cat->meta call will blow
  53         # up in our face
  54         Catalyst::Exception->throw("Must specify a test app: use Catalyst::Test 'TestApp'") unless $class;
  55
  56         # place holder for $c after the request finishes; reset every time
  57         # requests are done.
  58         my $ctx_closed_over;
  59
  60         # hook into 'dispatch' -- the function gets called after all plugins
  61         # have done their work, and it's an easy place to capture $c.
  62         my $meta = find_meta($class);
  63         $meta->make_mutable;
  64         $meta->add_after_method_modifier( "dispatch", sub {
  65             $ctx_closed_over = shift;
  66         });
  67         $meta->make_immutable( replace_constructor => 1 );
  68         Class::C3::reinitialize(); # Fixes RT#46459, I've failed to write a test for how/why, but it does.
  69
  70         # do the request; C::T::request will know about the class name, and
  71         # we've already stopped it from doing remote requests above.
  72         my $res = $args->{request}->( @_ );
  73
  74         # Make sure not to leave a reference $ctx hanging around.
  75         # This means that the context will go out of scope as soon as the
  76         # caller disposes of it, rather than waiting till the next time
  77         # that ctx_request is called. This can be important if your $ctx
  78         # ends up with a reference to a shared resource or lock (for example)
  79         # which you want to clean up in test teardown - if the $ctx is still
  80         # closed over then you're stuffed...
  81         my $ctx = $ctx_closed_over;
  82         undef $ctx_closed_over;
  83
  84         return ( $res, $ctx );
  85     };
  86 }
  87
  88 my $build_exports = sub {
  89     my ($self, $meth, $args, $defaults) = @_;
  90     my $class = $args->{class};
  91
  92     my $request = $self->_build_request_export({
  93         class  => $class,
  94         remote => $ENV{CATALYST_SERVER},
  95     });
  96
  97     my $get = $self->_build_get_export({ request => $request });
  98
  99     my $ctx_request = $self->_build_ctx_request_export({
 100         class   => $class,
 101         request => $request,
 102     });
 103
 104     return {
 105         request      => $request,
 106         get          => $get,
 107         ctx_request  => $ctx_request,
 108         content_like => sub {
 109             my $action = shift;
 110             return Test::More->builder->like($get->($action),@_);
 111         },
 112         action_ok => sub {
 113             my $action = shift;
 114             my $meth = $request->($action)->request->method;
 115             my @args = @_ ? @_ : ("$meth $action returns successfully");
 116             return Test::More->builder->ok($request->($action)->is_success,@args);
 117         },
 118         action_redirect => sub {
 119             my $action = shift;
 120             my $meth = $request->($action)->request->method;
 121             my @args = @_ ? @_ : ("$meth $action returns a redirect");
 122             return Test::More->builder->ok($request->($action)->is_redirect,@args);
 123         },
 124         action_notfound => sub {
 125             my $action = shift;
 126             my $meth = $request->($action)->request->method;
 127             my @args = @_ ? @_ : ("$meth $action returns a 404");
 128             return Test::More->builder->is_eq($request->($action)->code,404,@args);
 129         },
 130         contenttype_is => sub {
 131             my $action = shift;
 132             my $res = $request->($action);
 133             return Test::More->builder->is_eq(scalar($res->content_type),@_);
 134         },
 135     };
 136 };
 137
 138 our $default_host;
 139
 140 {
 141     my $import = Sub::Exporter::build_exporter({
 142         groups => [ all => $build_exports ],
 143         into_level => 1,
 144     });
 145
 146
 147     sub import {
 148         my ($self, $class, $opts) = @_;
 149         Carp::carp(
 150 qq{Importing Catalyst::Test without an application name is deprecated:\n
 151 Instead of saying: use Catalyst::Test;
 152 say: use Catalyst::Test (); # If you don't want to import a test app right now.
 153 or say: use Catalyst::Test 'MyApp'; # If you do want to import a test app.\n\n})
 154         unless $class;
 155         $import->($self, '-all' => { class => $class });
 156         $opts = {} unless ref $opts eq 'HASH';
 157         $default_host = $opts->{default_host} if exists $opts->{default_host};
 158         return 1;
 159     }
 160 }
 161
 162 =head1 NAME
 163
 164 Catalyst::Test - Test Catalyst Applications
 165
 166 =head1 SYNOPSIS
 167
 168     # Helper
 169     script/test.pl
 170
 171     # Tests
 172     use Catalyst::Test 'TestApp';
 173     my $content  = get('index.html');           # Content as string
 174     my $response = request('index.html');       # HTTP::Response object
 175     my($res, $c) = ctx_request('index.html');      # HTTP::Response & context object
 176
 177     use HTTP::Request::Common;
 178     my $response = request POST '/foo', [
 179         bar => 'baz',
 180         something => 'else'
 181     ];
 182
 183     # Run tests against a remote server
 184     CATALYST_SERVER='http://localhost:3000/' prove -r -l lib/ t/
 185
 186     use Catalyst::Test 'TestApp';
 187     use Test::More tests => 1;
 188
 189     ok( get('/foo') =~ /bar/ );
 190
 191     # mock virtual hosts
 192     use Catalyst::Test 'MyApp', { default_host => 'myapp.com' };
 193     like( get('/whichhost'), qr/served by myapp.com/ );
 194     like( get( '/whichhost', { host => 'yourapp.com' } ), qr/served by yourapp.com/ );
 195     {
 196         local $Catalyst::Test::default_host = 'otherapp.com';
 197         like( get('/whichhost'), qr/served by otherapp.com/ );
 198     }
 199
 200 =head1 DESCRIPTION
 201
 202 This module allows you to make requests to a Catalyst application either without
 203 a server, by simulating the environment of an HTTP request using
 204 L<HTTP::Request::AsCGI> or remotely if you define the CATALYST_SERVER
 205 environment variable. This module also adds a few Catalyst-specific
 206 testing methods as displayed in the method section.
 207
 208 The L<get|/"$content = get( ... )"> and L<request|/"$res = request( ... );">
 209 functions take either a URI or an L<HTTP::Request> object.
 210
 211 =head1 INLINE TESTS WILL NO LONGER WORK
 212
 213 While it used to be possible to inline a whole test app into a C<.t> file for
 214 a distribution, this will no longer work.
 215
 216 The convention is to place your L<Catalyst> test apps into C<t/lib> in your
 217 distribution. E.g.: C<t/lib/TestApp.pm>, C<t/lib/TestApp/Controller/Root.pm>,
 218 etc..  Multiple test apps can be used in this way.
 219
 220 Then write your C<.t> files like so:
 221
 222     use strict;
 223     use warnings;
 224     use FindBin '$Bin';
 225     use lib "$Bin/lib";
 226     use Test::More tests => 6;
 227     use Catalyst::Test 'TestApp';
 228
 229 =head1 METHODS
 230
 231 =head2 $content = get( ... )
 232
 233 Returns the content.
 234
 235     my $content = get('foo/bar?test=1');
 236
 237 Note that this method doesn't follow redirects, so to test for a
 238 correctly redirecting page you'll need to use a combination of this
 239 method and the L<request|/"$res = request( ... );"> method below:
 240
 241     my $res = request('/'); # redirects to /y
 242     warn $res->header('location');
 243     use URI;
 244     my $uri = URI->new($res->header('location'));
 245     is ( $uri->path , '/y');
 246     my $content = get($uri->path);
 247
 248 Note also that the content is returned as raw bytes, without any attempt
 249 to decode it into characters.
 250
 251 =head2 $res = request( ... );
 252
 253 Returns an L<HTTP::Response> object. Accepts an optional hashref for request
 254 header configuration; currently only supports setting 'host' value.
 255
 256     my $res = request('foo/bar?test=1');
 257     my $virtual_res = request('foo/bar?test=1', {host => 'virtualhost.com'});
 258
 259 =head2 ($res, $c) = ctx_request( ... );
 260
 261 Works exactly like L<request|/"$res = request( ... );">, except it also returns the Catalyst context object,
 262 C<$c>. Note that this only works for local requests.
 263
 264 =cut
 265
 266 sub _request {
 267     my $args = shift;
 268
 269     my $request = Catalyst::Utils::request(shift);
 270
 271     my %extra_env;
 272     _customize_request($request, \%extra_env, @_);
 273     $args->{mangle_request}->($request) if $args->{mangle_request};
 274
 275     my $ret;
 276     test_psgi
 277         %{ $args },
 278         app    => sub { $args->{app}->({ %{ $_[0] }, %extra_env }) },
 279         client => sub {
 280             my ($psgi_app) = @_;
 281             my $resp = $psgi_app->($request);
 282             $args->{mangle_response}->($resp) if $args->{mangle_response};
 283             $ret = $resp;
 284         };
 285
 286     return $ret;
 287 }
 288
 289 sub _local_request {
 290     my $class = shift;
 291
 292     return _request({
 293         app => ref($class) eq "CODE" ? $class : $class->_finalized_psgi_app,
 294         mangle_response => sub {
 295             my ($resp) = @_;
 296
 297             # HTML head parsing based on LWP::UserAgent
 298             #
 299             # This is because if you make a remote request with LWP, then the
 300             # <BASE HREF="..."> from the returned HTML document will be used
 301             # to fill in $res->base, as documented in HTTP::Response. We need
 302             # to support this in local test requests so that they work 'the same'.
 303             #
 304             # This is not just horrible and possibly broken, but also really
 305             # doesn't belong here. Whoever wants this should be working on
 306             # getting it into Plack::Test, or make a middleware out of it, or
 307             # whatever. Seriously - horrible.
 308
 309             if (!$resp->content_type || $resp->content_is_html) {
 310                 require HTML::HeadParser;
 311
 312                 my $parser = HTML::HeadParser->new();
 313                 $parser->xml_mode(1) if $resp->content_is_xhtml;
 314                 $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
 315
 316                 $parser->parse( $resp->content );
 317                 my $h = $parser->header;
 318                 for my $f ( $h->header_field_names ) {
 319                     $resp->init_header( $f, [ $h->header($f) ] );
 320                 }
 321             }
 322             # Another horrible hack to make the response headers have a
 323             # 'status' field. This is for back-compat, but you should
 324             # call $resp->code instead!
 325             $resp->init_header('status', [ $resp->code ]);
 326         },
 327     }, @_);
 328 }
 329
 330 my $agent;
 331
 332 sub _remote_request {
 333     require LWP::UserAgent;
 334     local $Plack::Test::Impl = 'ExternalServer';
 335
 336     unless ($agent) {
 337         $agent = LWP::UserAgent->new(
 338             keep_alive   => 1,
 339             max_redirect => 0,
 340             timeout      => 60,
 341
 342             # work around newer LWP max_redirect 0 bug
 343             # http://rt.cpan.org/Ticket/Display.html?id=40260
 344             requests_redirectable => [],
 345         );
 346
 347         $agent->env_proxy;
 348     }
 349
 350
 351     my $server = URI->new($ENV{CATALYST_SERVER});
 352     if ( $server->path =~ m|^(.+)?/$| ) {
 353         my $path = $1;
 354         $server->path("$path") if $path;    # need to be quoted
 355     }
 356
 357     return _request({
 358         ua             => $agent,
 359         uri            => $server,
 360         mangle_request => sub {
 361             my ($request) = @_;
 362
 363             # the request path needs to be sanitised if $server is using a
 364             # non-root path due to potential overlap between request path and
 365             # response path.
 366             if ($server->path) {
 367                 # If request path is '/', we have to add a trailing slash to the
 368                 # final request URI
 369                 my $add_trailing = ($request->uri->path eq '/' || $request->uri->path eq '') ? 1 : 0;
 370
 371                 my @sp = split '/', $server->path;
 372                 my @rp = split '/', $request->uri->path;
 373                 shift @sp; shift @rp; # leading /
 374                 if (@rp) {
 375                     foreach my $sp (@sp) {
 376                         $sp eq $rp[0] ? shift @rp : last
 377                     }
 378                 }
 379                 $request->uri->path(join '/', @rp);
 380
 381                 if ( $add_trailing ) {
 382                     $request->uri->path( $request->uri->path . '/' );
 383                 }
 384             }
 385         },
 386     }, @_);
 387 }
 388
 389 for my $name (qw(local_request remote_request)) {
 390     my $fun = sub {
 391         carp <<"EOW";
 392 Calling Catalyst::Test::${name}() directly is deprecated.
 393
 394 Please import Catalyst::Test into your namespace and use the provided request()
 395 function instead.
 396 EOW
 397         return __PACKAGE__->can("_${name}")->(@_);
 398     };
 399
 400     no strict 'refs';
 401     *$name = $fun;
 402 }
 403
 404 sub _customize_request {
 405     my $request = shift;
 406     my $extra_env = shift;
 407     my $opts = pop(@_) || {};
 408     $opts = {} unless ref($opts) eq 'HASH';
 409     if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host  ) {
 410         $request->header( 'Host' => $host );
 411     }
 412
 413     if (my $extra = $opts->{extra_env}) {
 414         @{ $extra_env }{keys %{ $extra }} = values %{ $extra };
 415     }
 416 }
 417
 418 =head2 action_ok($url [, $test_name ])
 419
 420 Fetches the given URL and checks that the request was successful. An optional
 421 second argument can be given to specify the name of the test.
 422
 423 =head2 action_redirect($url [, $test_name ])
 424
 425 Fetches the given URL and checks that the request was a redirect. An optional
 426 second argument can be given to specify the name of the test.
 427
 428 =head2 action_notfound($url [, $test_name ])
 429
 430 Fetches the given URL and checks that the request was not found. An optional
 431 second argument can be given to specify the name of the test.
 432
 433 =head2 content_like( $url, $regexp [, $test_name ] )
 434
 435 Fetches the given URL and returns whether the content matches the regexp. An
 436 optional third argument can be given to specify the name of the test.
 437
 438 =head2 contenttype_is($url, $type [, $test_name ])
 439
 440 Verify the given URL has a content type of $type and optionally specify a test name.
 441
 442 =head1 SEE ALSO
 443
 444 L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
 445 L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common>
 446
 447 =head1 AUTHORS
 448
 449 Catalyst Contributors, see Catalyst.pm
 450
 451 =head1 COPYRIGHT
 452
 453 This library is free software. You can redistribute it and/or modify it under
 454 the same terms as Perl itself.
 455
 456 =begin Pod::Coverage
 457
 458 local_request
 459
 460 remote_request
 461
 462 =end Pod::Coverage
 463
 464 =cut
 465
 466 1;