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 Alternately, you can pass in an L<HTTP::Request::Common> object to set arbitrary
 260 request headers.
 261
 262     my $res = request(GET '/foo/bar',
 263         X-Foo => 'Bar',
 264         Authorization => 'Bearer JWT_HERE',
 265         ...
 266     );
 267
 268 =head2 ($res, $c) = ctx_request( ... );
 269
 270 Works exactly like L<request|/"$res = request( ... );">, except it also returns the Catalyst context object,
 271 C<$c>. Note that this only works for local requests.
 272
 273 =cut
 274
 275 sub _request {
 276     my $args = shift;
 277
 278     my $request = Catalyst::Utils::request(shift);
 279
 280     my %extra_env;
 281     _customize_request($request, \%extra_env, @_);
 282     $args->{mangle_request}->($request) if $args->{mangle_request};
 283
 284     my $ret;
 285     test_psgi
 286         %{ $args },
 287         app    => sub { $args->{app}->({ %{ $_[0] }, %extra_env }) },
 288         client => sub {
 289             my ($psgi_app) = @_;
 290             my $resp = $psgi_app->($request);
 291             $args->{mangle_response}->($resp) if $args->{mangle_response};
 292             $ret = $resp;
 293         };
 294
 295     return $ret;
 296 }
 297
 298 sub _local_request {
 299     my $class = shift;
 300
 301     return _request({
 302         app => ref($class) eq "CODE" ? $class : $class->_finalized_psgi_app,
 303         mangle_response => sub {
 304             my ($resp) = @_;
 305
 306             # HTML head parsing based on LWP::UserAgent
 307             #
 308             # This is because if you make a remote request with LWP, then the
 309             # <BASE HREF="..."> from the returned HTML document will be used
 310             # to fill in $res->base, as documented in HTTP::Response. We need
 311             # to support this in local test requests so that they work 'the same'.
 312             #
 313             # This is not just horrible and possibly broken, but also really
 314             # doesn't belong here. Whoever wants this should be working on
 315             # getting it into Plack::Test, or make a middleware out of it, or
 316             # whatever. Seriously - horrible.
 317
 318             if (!$resp->content_type || $resp->content_is_html) {
 319                 require HTML::HeadParser;
 320
 321                 my $parser = HTML::HeadParser->new();
 322                 $parser->xml_mode(1) if $resp->content_is_xhtml;
 323                 $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
 324
 325                 $parser->parse( $resp->content );
 326                 my $h = $parser->header;
 327                 for my $f ( $h->header_field_names ) {
 328                     $resp->init_header( $f, [ $h->header($f) ] );
 329                 }
 330             }
 331             # Another horrible hack to make the response headers have a
 332             # 'status' field. This is for back-compat, but you should
 333             # call $resp->code instead!
 334             $resp->init_header('status', [ $resp->code ]);
 335         },
 336     }, @_);
 337 }
 338
 339 my $agent;
 340
 341 sub _remote_request {
 342     require LWP::UserAgent;
 343     local $Plack::Test::Impl = 'ExternalServer';
 344
 345     unless ($agent) {
 346         $agent = LWP::UserAgent->new(
 347             keep_alive   => 1,
 348             max_redirect => 0,
 349             timeout      => 60,
 350
 351             # work around newer LWP max_redirect 0 bug
 352             # http://rt.cpan.org/Ticket/Display.html?id=40260
 353             requests_redirectable => [],
 354         );
 355
 356         $agent->env_proxy;
 357     }
 358
 359
 360     my $server = URI->new($ENV{CATALYST_SERVER});
 361     if ( $server->path =~ m|^(.+)?/$| ) {
 362         my $path = $1;
 363         $server->path("$path") if $path;    # need to be quoted
 364     }
 365
 366     return _request({
 367         ua             => $agent,
 368         uri            => $server,
 369         mangle_request => sub {
 370             my ($request) = @_;
 371
 372             # the request path needs to be sanitised if $server is using a
 373             # non-root path due to potential overlap between request path and
 374             # response path.
 375             if ($server->path) {
 376                 # If request path is '/', we have to add a trailing slash to the
 377                 # final request URI
 378                 my $add_trailing = ($request->uri->path eq '/' || $request->uri->path eq '') ? 1 : 0;
 379
 380                 my @sp = split '/', $server->path;
 381                 my @rp = split '/', $request->uri->path;
 382                 shift @sp; shift @rp; # leading /
 383                 if (@rp) {
 384                     foreach my $sp (@sp) {
 385                         $sp eq $rp[0] ? shift @rp : last
 386                     }
 387                 }
 388                 $request->uri->path(join '/', @rp);
 389
 390                 if ( $add_trailing ) {
 391                     $request->uri->path( $request->uri->path . '/' );
 392                 }
 393             }
 394         },
 395     }, @_);
 396 }
 397
 398 for my $name (qw(local_request remote_request)) {
 399     my $fun = sub {
 400         carp <<"EOW";
 401 Calling Catalyst::Test::${name}() directly is deprecated.
 402
 403 Please import Catalyst::Test into your namespace and use the provided request()
 404 function instead.
 405 EOW
 406         return __PACKAGE__->can("_${name}")->(@_);
 407     };
 408
 409     no strict 'refs';
 410     *$name = $fun;
 411 }
 412
 413 sub _customize_request {
 414     my $request = shift;
 415     my $extra_env = shift;
 416     my $opts = pop(@_) || {};
 417     $opts = {} unless ref($opts) eq 'HASH';
 418     if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host  ) {
 419         $request->header( 'Host' => $host );
 420     }
 421
 422     if (my $extra = $opts->{extra_env}) {
 423         @{ $extra_env }{keys %{ $extra }} = values %{ $extra };
 424     }
 425 }
 426
 427 =head2 action_ok($url [, $test_name ])
 428
 429 Fetches the given URL and checks that the request was successful. An optional
 430 second argument can be given to specify the name of the test.
 431
 432 =head2 action_redirect($url [, $test_name ])
 433
 434 Fetches the given URL and checks that the request was a redirect. An optional
 435 second argument can be given to specify the name of the test.
 436
 437 =head2 action_notfound($url [, $test_name ])
 438
 439 Fetches the given URL and checks that the request was not found. An optional
 440 second argument can be given to specify the name of the test.
 441
 442 =head2 content_like( $url, $regexp [, $test_name ] )
 443
 444 Fetches the given URL and returns whether the content matches the regexp. An
 445 optional third argument can be given to specify the name of the test.
 446
 447 =head2 contenttype_is($url, $type [, $test_name ])
 448
 449 Verify the given URL has a content type of $type and optionally specify a test name.
 450
 451 =head1 SEE ALSO
 452
 453 L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
 454 L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common>
 455
 456 =head1 AUTHORS
 457
 458 Catalyst Contributors, see Catalyst.pm
 459
 460 =head1 COPYRIGHT
 461
 462 This library is free software. You can redistribute it and/or modify it under
 463 the same terms as Perl itself.
 464
 465 =begin Pod::Coverage
 466
 467 local_request
 468
 469 remote_request
 470
 471 =end Pod::Coverage
 472
 473 =cut
 474
 475 1;