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