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 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     load_class($class) unless 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 because if you make a remote request with LWP, then the
 299             # <BASE HREF="..."> from the returned HTML document will be used
 300             # to fill in $res->base, as documented in HTTP::Response. We need
 301             # to support this in local test requests so that they work 'the same'.
 302             #
 303             # This is not just horrible and possibly broken, but also really
 304             # doesn't belong here. Whoever wants this should be working on
 305             # getting it into Plack::Test, or make a middleware out of it, or
 306             # whatever. Seriously - horrible.
 307
 308             if (!$resp->content_type || $resp->content_is_html) {
 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             }
 321             # Another horrible hack to make the response headers have a
 322             # 'status' field. This is for back-compat, but you should
 323             # call $resp->code instead!
 324             $resp->init_header('status', [ $resp->code ]);
 325         },
 326     }, @_);
 327 }
 328
 329 my $agent;
 330
 331 sub _remote_request {
 332     require LWP::UserAgent;
 333     local $Plack::Test::Impl = 'ExternalServer';
 334
 335     unless ($agent) {
 336         $agent = LWP::UserAgent->new(
 337             keep_alive   => 1,
 338             max_redirect => 0,
 339             timeout      => 60,
 340
 341             # work around newer LWP max_redirect 0 bug
 342             # http://rt.cpan.org/Ticket/Display.html?id=40260
 343             requests_redirectable => [],
 344         );
 345
 346         $agent->env_proxy;
 347     }
 348
 349
 350     my $server = URI->new($ENV{CATALYST_SERVER});
 351     if ( $server->path =~ m|^(.+)?/$| ) {
 352         my $path = $1;
 353         $server->path("$path") if $path;    # need to be quoted
 354     }
 355
 356     return _request({
 357         ua             => $agent,
 358         uri            => $server,
 359         mangle_request => sub {
 360             my ($request) = @_;
 361
 362             # the request path needs to be sanitised if $server is using a
 363             # non-root path due to potential overlap between request path and
 364             # response path.
 365             if ($server->path) {
 366                 # If request path is '/', we have to add a trailing slash to the
 367                 # final request URI
 368                 my $add_trailing = ($request->uri->path eq '/' || $request->uri->path eq '') ? 1 : 0;
 369
 370                 my @sp = split '/', $server->path;
 371                 my @rp = split '/', $request->uri->path;
 372                 shift @sp; shift @rp; # leading /
 373                 if (@rp) {
 374                     foreach my $sp (@sp) {
 375                         $sp eq $rp[0] ? shift @rp : last
 376                     }
 377                 }
 378                 $request->uri->path(join '/', @rp);
 379
 380                 if ( $add_trailing ) {
 381                     $request->uri->path( $request->uri->path . '/' );
 382                 }
 383             }
 384         },
 385     }, @_);
 386 }
 387
 388 for my $name (qw(local_request remote_request)) {
 389     my $fun = sub {
 390         carp <<"EOW";
 391 Calling Catalyst::Test::${name}() directly is deprecated.
 392
 393 Please import Catalyst::Test into your namespace and use the provided request()
 394 function instead.
 395 EOW
 396         return __PACKAGE__->can("_${name}")->(@_);
 397     };
 398
 399     no strict 'refs';
 400     *$name = $fun;
 401 }
 402
 403 sub _customize_request {
 404     my $request = shift;
 405     my $extra_env = shift;
 406     my $opts = pop(@_) || {};
 407     $opts = {} unless ref($opts) eq 'HASH';
 408     if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host  ) {
 409         $request->header( 'Host' => $host );
 410     }
 411
 412     if (my $extra = $opts->{extra_env}) {
 413         @{ $extra_env }{keys %{ $extra }} = values %{ $extra };
 414     }
 415 }
 416
 417 =head2 action_ok($url [, $test_name ])
 418
 419 Fetches the given URL and checks that the request was successful. An optional
 420 second argument can be given to specify the name of the test.
 421
 422 =head2 action_redirect($url [, $test_name ])
 423
 424 Fetches the given URL and checks that the request was a redirect. An optional
 425 second argument can be given to specify the name of the test.
 426
 427 =head2 action_notfound($url [, $test_name ])
 428
 429 Fetches the given URL and checks that the request was not found. An optional
 430 second argument can be given to specify the name of the test.
 431
 432 =head2 content_like( $url, $regexp [, $test_name ] )
 433
 434 Fetches the given URL and returns whether the content matches the regexp. An
 435 optional third argument can be given to specify the name of the test.
 436
 437 =head2 contenttype_is($url, $type [, $test_name ])
 438
 439 Verify the given URL has a content type of $type and optionally specify a test name.
 440
 441 =head1 SEE ALSO
 442
 443 L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
 444 L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common>
 445
 446 =head1 AUTHORS
 447
 448 Catalyst Contributors, see Catalyst.pm
 449
 450 =head1 COPYRIGHT
 451
 452 This library is free software. You can redistribute it and/or modify it under
 453 the same terms as Perl itself.
 454
 455 =begin Pod::Coverage
 456
 457 local_request
 458
 459 remote_request
 460
 461 =end Pod::Coverage
 462
 463 =cut
 464
 465 1;