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::MOP;
  11 use Sub::Exporter;
  12 use Carp 'croak', 'carp';
  13
  14 sub _build_request_export {
  15     my ($self, $args) = @_;
  16
  17     return sub { _remote_request(@_) }
  18         if $args->{remote};
  19
  20     my $class = $args->{class};
  21
  22     # Here we should be failing right away, but for some stupid backcompat thing
  23     # I don't quite remember we fail lazily here. Needs a proper deprecation and
  24     # then removal.
  25     return sub { croak "Must specify a test app: use Catalyst::Test 'TestApp'" }
  26         unless $class;
  27
  28     warn "LOAD $class " . Class::MOP::is_class_loaded($class);
  29     Class::MOP::load_class($class) unless Class::MOP::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 = Class::MOP::get_metaclass_by_name($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             require HTML::HeadParser;
 310
 311             my $parser = HTML::HeadParser->new();
 312             $parser->xml_mode(1) if $resp->content_is_xhtml;
 313             $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
 314
 315             $parser->parse( $resp->content );
 316             my $h = $parser->header;
 317             for my $f ( $h->header_field_names ) {
 318                 $resp->init_header( $f, [ $h->header($f) ] );
 319             }
 320             # Another horrible hack to make the response headers have a
 321             # 'status' field. This is for back-compat, but you should
 322             # call $resp->code instead!
 323             $resp->init_header('status', [ $resp->code ]);
 324         },
 325     }, @_);
 326 }
 327
 328 my $agent;
 329
 330 sub _remote_request {
 331     require LWP::UserAgent;
 332     local $Plack::Test::Impl = 'ExternalServer';
 333
 334     unless ($agent) {
 335         $agent = LWP::UserAgent->new(
 336             keep_alive   => 1,
 337             max_redirect => 0,
 338             timeout      => 60,
 339
 340             # work around newer LWP max_redirect 0 bug
 341             # http://rt.cpan.org/Ticket/Display.html?id=40260
 342             requests_redirectable => [],
 343         );
 344
 345         $agent->env_proxy;
 346     }
 347
 348
 349     my $server = URI->new($ENV{CATALYST_SERVER});
 350     if ( $server->path =~ m|^(.+)?/$| ) {
 351         my $path = $1;
 352         $server->path("$path") if $path;    # need to be quoted
 353     }
 354
 355     return _request({
 356         ua             => $agent,
 357         uri            => $server,
 358         mangle_request => sub {
 359             my ($request) = @_;
 360
 361             # the request path needs to be sanitised if $server is using a
 362             # non-root path due to potential overlap between request path and
 363             # response path.
 364             if ($server->path) {
 365                 # If request path is '/', we have to add a trailing slash to the
 366                 # final request URI
 367                 my $add_trailing = ($request->uri->path eq '/' || $request->uri->path eq '') ? 1 : 0;
 368
 369                 my @sp = split '/', $server->path;
 370                 my @rp = split '/', $request->uri->path;
 371                 shift @sp; shift @rp; # leading /
 372                 if (@rp) {
 373                     foreach my $sp (@sp) {
 374                         $sp eq $rp[0] ? shift @rp : last
 375                     }
 376                 }
 377                 $request->uri->path(join '/', @rp);
 378
 379                 if ( $add_trailing ) {
 380                     $request->uri->path( $request->uri->path . '/' );
 381                 }
 382             }
 383         },
 384     }, @_);
 385 }
 386
 387 for my $name (qw(local_request remote_request)) {
 388     my $fun = sub {
 389         carp <<"EOW";
 390 Calling Catalyst::Test::${name}() directly is deprecated.
 391
 392 Please import Catalyst::Test into your namespace and use the provided request()
 393 function instead.
 394 EOW
 395         return __PACKAGE__->can("_${name}")->(@_);
 396     };
 397
 398     no strict 'refs';
 399     *$name = $fun;
 400 }
 401
 402 sub _customize_request {
 403     my $request = shift;
 404     my $extra_env = shift;
 405     my $opts = pop(@_) || {};
 406     $opts = {} unless ref($opts) eq 'HASH';
 407     if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host  ) {
 408         $request->header( 'Host' => $host );
 409     }
 410
 411     if (my $extra = $opts->{extra_env}) {
 412         @{ $extra_env }{keys %{ $extra }} = values %{ $extra };
 413     }
 414 }
 415
 416 =head2 action_ok($url [, $test_name ])
 417
 418 Fetches the given URL and checks that the request was successful. An optional
 419 second argument can be given to specify the name of the test.
 420
 421 =head2 action_redirect($url [, $test_name ])
 422
 423 Fetches the given URL and checks that the request was a redirect. An optional
 424 second argument can be given to specify the name of the test.
 425
 426 =head2 action_notfound($url [, $test_name ])
 427
 428 Fetches the given URL and checks that the request was not found. An optional
 429 second argument can be given to specify the name of the test.
 430
 431 =head2 content_like( $url, $regexp [, $test_name ] )
 432
 433 Fetches the given URL and returns whether the content matches the regexp. An
 434 optional third argument can be given to specify the name of the test.
 435
 436 =head2 contenttype_is($url, $type [, $test_name ])
 437
 438 Verify the given URL has a content type of $type and optionally specify a test name.
 439
 440 =head1 SEE ALSO
 441
 442 L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
 443 L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common>
 444
 445 =head1 AUTHORS
 446
 447 Catalyst Contributors, see Catalyst.pm
 448
 449 =head1 COPYRIGHT
 450
 451 This library is free software. You can redistribute it and/or modify it under
 452 the same terms as Perl itself.
 453
 454 =begin Pod::Coverage
 455
 456 local_request
 457
 458 remote_request
 459
 460 =end Pod::Coverage
 461
 462 =cut
 463
 464 1;