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