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             return Test::More->builder->ok($request->($action)->is_success, @_);
 114         },
 115         action_redirect => sub {
 116             my $action = shift;
 117             return Test::More->builder->ok($request->($action)->is_redirect,@_);
 118         },
 119         action_notfound => sub {
 120             my $action = shift;
 121             return Test::More->builder->is_eq($request->($action)->code,404,@_);
 122         },
 123         contenttype_is => sub {
 124             my $action = shift;
 125             my $res = $request->($action);
 126             return Test::More->builder->is_eq(scalar($res->content_type),@_);
 127         },
 128     };
 129 };
 130
 131 our $default_host;
 132
 133 {
 134     my $import = Sub::Exporter::build_exporter({
 135         groups => [ all => $build_exports ],
 136         into_level => 1,
 137     });
 138
 139
 140     sub import {
 141         my ($self, $class, $opts) = @_;
 142         Carp::carp(
 143 qq{Importing Catalyst::Test without an application name is deprecated:\n
 144 Instead of saying: use Catalyst::Test;
 145 say: use Catalyst::Test (); # If you don't want to import a test app right now.
 146 or say: use Catalyst::Test 'MyApp'; # If you do want to import a test app.\n\n})
 147         unless $class;
 148         $import->($self, '-all' => { class => $class });
 149         $opts = {} unless ref $opts eq 'HASH';
 150         $default_host = $opts->{default_host} if exists $opts->{default_host};
 151         return 1;
 152     }
 153 }
 154
 155 =head1 NAME
 156
 157 Catalyst::Test - Test Catalyst Applications
 158
 159 =head1 SYNOPSIS
 160
 161     # Helper
 162     script/test.pl
 163
 164     # Tests
 165     use Catalyst::Test 'TestApp';
 166     my $content  = get('index.html');           # Content as string
 167     my $response = request('index.html');       # HTTP::Response object
 168     my($res, $c) = ctx_request('index.html');      # HTTP::Response & context object
 169
 170     use HTTP::Request::Common;
 171     my $response = request POST '/foo', [
 172         bar => 'baz',
 173         something => 'else'
 174     ];
 175
 176     # Run tests against a remote server
 177     CATALYST_SERVER='http://localhost:3000/' prove -r -l lib/ t/
 178
 179     use Catalyst::Test 'TestApp';
 180     use Test::More tests => 1;
 181
 182     ok( get('/foo') =~ /bar/ );
 183
 184     # mock virtual hosts
 185     use Catalyst::Test 'MyApp', { default_host => 'myapp.com' };
 186     like( get('/whichhost'), qr/served by myapp.com/ );
 187     like( get( '/whichhost', { host => 'yourapp.com' } ), qr/served by yourapp.com/ );
 188     {
 189         local $Catalyst::Test::default_host = 'otherapp.com';
 190         like( get('/whichhost'), qr/served by otherapp.com/ );
 191     }
 192
 193 =head1 DESCRIPTION
 194
 195 This module allows you to make requests to a Catalyst application either without
 196 a server, by simulating the environment of an HTTP request using
 197 L<HTTP::Request::AsCGI> or remotely if you define the CATALYST_SERVER
 198 environment variable. This module also adds a few Catalyst-specific
 199 testing methods as displayed in the method section.
 200
 201 The L<get|/"$content = get( ... )"> and L<request|/"$res = request( ... );">
 202 functions take either a URI or an L<HTTP::Request> object.
 203
 204 =head1 INLINE TESTS WILL NO LONGER WORK
 205
 206 While it used to be possible to inline a whole testapp into a C<.t> file for a
 207 distribution, this will no longer work.
 208
 209 The convention is to place your L<Catalyst> test apps into C<t/lib> in your
 210 distribution. E.g.: C<t/lib/TestApp.pm>, C<t/lib/TestApp/Controller/Root.pm>,
 211 etc..  Multiple test apps can be used in this way.
 212
 213 Then write your C<.t> files like so:
 214
 215     use strict;
 216     use warnings;
 217     use FindBin '$Bin';
 218     use lib "$Bin/lib";
 219     use Test::More tests => 6;
 220     use Catalyst::Test 'TestApp';
 221
 222 =head1 METHODS
 223
 224 =head2 $content = get( ... )
 225
 226 Returns the content.
 227
 228     my $content = get('foo/bar?test=1');
 229
 230 Note that this method doesn't follow redirects, so to test for a
 231 correctly redirecting page you'll need to use a combination of this
 232 method and the L<request|/"$res = request( ... );"> method below:
 233
 234     my $res = request('/'); # redirects to /y
 235     warn $res->header('location');
 236     use URI;
 237     my $uri = URI->new($res->header('location'));
 238     is ( $uri->path , '/y');
 239     my $content = get($uri->path);
 240
 241 Note also that the content is returned as raw bytes, without any attempt
 242 to decode it into characters.
 243
 244 =head2 $res = request( ... );
 245
 246 Returns an L<HTTP::Response> object. Accepts an optional hashref for request
 247 header configuration; currently only supports setting 'host' value.
 248
 249     my $res = request('foo/bar?test=1');
 250     my $virtual_res = request('foo/bar?test=1', {host => 'virtualhost.com'});
 251
 252 =head2 ($res, $c) = ctx_request( ... );
 253
 254 Works exactly like L<request|/"$res = request( ... );">, except it also returns the Catalyst context object,
 255 C<$c>. Note that this only works for local requests.
 256
 257 =cut
 258
 259 sub _local_request {
 260     my $class = shift;
 261
 262     my $app = ref($class) eq "CODE" ? $class : $class->_finalized_psgi_app;
 263
 264     my $request = Catalyst::Utils::request(shift);
 265     my %extra_env;
 266     _customize_request($request, \%extra_env, @_);
 267
 268     my $ret;
 269     test_psgi
 270         app    => sub { $app->({ %{ $_[0] }, %extra_env }) },
 271         client => sub {
 272             my $psgi_app = shift;
 273
 274             my $resp = $psgi_app->($request);
 275
 276             # HTML head parsing based on LWP::UserAgent
 277             #
 278             # This is not just horrible and possibly broken, but also really
 279             # doesn't belong here. Whoever wants this should be working on
 280             # getting it into Plack::Test, or make a middleware out of it, or
 281             # whatever. Seriously - horrible.
 282
 283             require HTML::HeadParser;
 284
 285             my $parser = HTML::HeadParser->new();
 286             $parser->xml_mode(1) if $resp->content_is_xhtml;
 287             $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
 288
 289             $parser->parse( $resp->content );
 290             my $h = $parser->header;
 291             for my $f ( $h->header_field_names ) {
 292                 $resp->init_header( $f, [ $h->header($f) ] );
 293             }
 294
 295             $ret = $resp;
 296         };
 297
 298     return $ret;
 299 }
 300
 301 my $agent;
 302
 303 sub _remote_request {
 304     require LWP::UserAgent;
 305
 306     my $request = Catalyst::Utils::request( shift(@_) );
 307     my $server  = URI->new( $ENV{CATALYST_SERVER} );
 308
 309     _customize_request($request, @_);
 310
 311     if ( $server->path =~ m|^(.+)?/$| ) {
 312         my $path = $1;
 313         $server->path("$path") if $path;    # need to be quoted
 314     }
 315
 316     # the request path needs to be sanitised if $server is using a
 317     # non-root path due to potential overlap between request path and
 318     # response path.
 319     if ($server->path) {
 320         # If request path is '/', we have to add a trailing slash to the
 321         # final request URI
 322         my $add_trailing = $request->uri->path eq '/';
 323
 324         my @sp = split '/', $server->path;
 325         my @rp = split '/', $request->uri->path;
 326         shift @sp;shift @rp; # leading /
 327         if (@rp) {
 328             foreach my $sp (@sp) {
 329                 $sp eq $rp[0] ? shift @rp : last
 330             }
 331         }
 332         $request->uri->path(join '/', @rp);
 333
 334         if ( $add_trailing ) {
 335             $request->uri->path( $request->uri->path . '/' );
 336         }
 337     }
 338
 339     $request->uri->scheme( $server->scheme );
 340     $request->uri->host( $server->host );
 341     $request->uri->port( $server->port );
 342     $request->uri->path( $server->path . $request->uri->path );
 343
 344     unless ($agent) {
 345
 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     return $agent->request($request);
 360 }
 361
 362 for my $name (qw(local_request remote_request)) {
 363     my $fun = sub {
 364         carp <<"EOW";
 365 Calling Catalyst::Test::${name}() directly is deprecated.
 366
 367 Please import Catalyst::Test into your namespace and use the provided request()
 368 function instead.
 369 EOW
 370         return __PACKAGE__->can("_${name}")->(@_);
 371     };
 372
 373     no strict 'refs';
 374     *$name = $fun;
 375 }
 376
 377 sub _customize_request {
 378     my $request = shift;
 379     my $extra_env = shift;
 380     my $opts = pop(@_) || {};
 381     $opts = {} unless ref($opts) eq 'HASH';
 382     if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host  ) {
 383         $request->header( 'Host' => $host );
 384     }
 385
 386     if (my $extra = $opts->{extra_env}) {
 387         @{ $extra_env }{keys %{ $extra }} = values %{ $extra };
 388     }
 389 }
 390
 391 =head2 action_ok($url [, $test_name ])
 392
 393 Fetches the given URL and checks that the request was successful. An optional
 394 second argument can be given to specify the name of the test.
 395
 396 =head2 action_redirect($url [, $test_name ])
 397
 398 Fetches the given URL and checks that the request was a redirect. An optional
 399 second argument can be given to specify the name of the test.
 400
 401 =head2 action_notfound($url [, $test_name ])
 402
 403 Fetches the given URL and checks that the request was not found. An optional
 404 second argument can be given to specify the name of the test.
 405
 406 =head2 content_like( $url, $regexp [, $test_name ] )
 407
 408 Fetches the given URL and returns whether the content matches the regexp. An
 409 optional third argument can be given to specify the name of the test.
 410
 411 =head2 contenttype_is($url, $type [, $test_name ])
 412
 413 Verify the given URL has a content type of $type and optionally specify a test name.
 414
 415 =head1 SEE ALSO
 416
 417 L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
 418 L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common>
 419
 420 =head1 AUTHORS
 421
 422 Catalyst Contributors, see Catalyst.pm
 423
 424 =head1 COPYRIGHT
 425
 426 This library is free software. You can redistribute it and/or modify it under
 427 the same terms as Perl itself.
 428
 429 =begin Pod::Coverage
 430
 431 local_request
 432
 433 remote_request
 434
 435 =end Pod::Coverage
 436
 437 =cut
 438
 439 1;