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
 392
 393 Fetches the given URL and checks that the request was successful.
 394
 395 =head2 action_redirect
 396
 397 Fetches the given URL and checks that the request was a redirect.
 398
 399 =head2 action_notfound
 400
 401 Fetches the given URL and checks that the request was not found.
 402
 403 =head2 content_like( $url, $regexp [, $test_name] )
 404
 405 Fetches the given URL and returns whether the content matches the regexp.
 406
 407 =head2 contenttype_is
 408
 409 Check for given MIME type.
 410
 411 =head1 SEE ALSO
 412
 413 L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
 414 L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common>
 415
 416 =head1 AUTHORS
 417
 418 Catalyst Contributors, see Catalyst.pm
 419
 420 =head1 COPYRIGHT
 421
 422 This library is free software. You can redistribute it and/or modify it under
 423 the same terms as Perl itself.
 424
 425 =begin Pod::Coverage
 426
 427 local_request
 428
 429 remote_request
 430
 431 =end Pod::Coverage
 432
 433 =cut
 434
 435 1;