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 testapp into a C<.t> file for a
 213 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 _local_request {
 266     my $class = shift;
 267
 268     my $app = ref($class) eq "CODE" ? $class : $class->_finalized_psgi_app;
 269
 270     my $request = Catalyst::Utils::request(shift);
 271     my %extra_env;
 272     _customize_request($request, \%extra_env, @_);
 273
 274     my $ret;
 275     test_psgi
 276         app    => sub { $app->({ %{ $_[0] }, %extra_env }) },
 277         client => sub {
 278             my $psgi_app = shift;
 279
 280             my $resp = $psgi_app->($request);
 281
 282             # HTML head parsing based on LWP::UserAgent
 283             #
 284             # This is not just horrible and possibly broken, but also really
 285             # doesn't belong here. Whoever wants this should be working on
 286             # getting it into Plack::Test, or make a middleware out of it, or
 287             # whatever. Seriously - horrible.
 288
 289             require HTML::HeadParser;
 290
 291             my $parser = HTML::HeadParser->new();
 292             $parser->xml_mode(1) if $resp->content_is_xhtml;
 293             $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
 294
 295             $parser->parse( $resp->content );
 296             my $h = $parser->header;
 297             for my $f ( $h->header_field_names ) {
 298                 $resp->init_header( $f, [ $h->header($f) ] );
 299             }
 300
 301             $ret = $resp;
 302         };
 303
 304     return $ret;
 305 }
 306
 307 my $agent;
 308
 309 sub _remote_request {
 310     require LWP::UserAgent;
 311
 312     my $request = Catalyst::Utils::request( shift(@_) );
 313     my $server  = URI->new( $ENV{CATALYST_SERVER} );
 314
 315     _customize_request($request, @_);
 316
 317     if ( $server->path =~ m|^(.+)?/$| ) {
 318         my $path = $1;
 319         $server->path("$path") if $path;    # need to be quoted
 320     }
 321
 322     # the request path needs to be sanitised if $server is using a
 323     # non-root path due to potential overlap between request path and
 324     # response path.
 325     if ($server->path) {
 326         # If request path is '/', we have to add a trailing slash to the
 327         # final request URI
 328         my $add_trailing = ($request->uri->path eq '/' || $request->uri->path eq '') ? 1 : 0;
 329
 330         my @sp = split '/', $server->path;
 331         my @rp = split '/', $request->uri->path;
 332         shift @sp;shift @rp; # leading /
 333         if (@rp) {
 334             foreach my $sp (@sp) {
 335                 $sp eq $rp[0] ? shift @rp : last
 336             }
 337         }
 338         $request->uri->path(join '/', @rp);
 339
 340         if ( $add_trailing ) {
 341             $request->uri->path( $request->uri->path . '/' );
 342         }
 343     }
 344
 345     $request->uri->scheme( $server->scheme );
 346     $request->uri->host( $server->host );
 347     $request->uri->port( $server->port );
 348     $request->uri->path( $server->path . $request->uri->path );
 349
 350     unless ($agent) {
 351
 352         $agent = LWP::UserAgent->new(
 353             keep_alive   => 1,
 354             max_redirect => 0,
 355             timeout      => 60,
 356
 357             # work around newer LWP max_redirect 0 bug
 358             # http://rt.cpan.org/Ticket/Display.html?id=40260
 359             requests_redirectable => [],
 360         );
 361
 362         $agent->env_proxy;
 363     }
 364
 365     return $agent->request($request);
 366 }
 367
 368 for my $name (qw(local_request remote_request)) {
 369     my $fun = sub {
 370         carp <<"EOW";
 371 Calling Catalyst::Test::${name}() directly is deprecated.
 372
 373 Please import Catalyst::Test into your namespace and use the provided request()
 374 function instead.
 375 EOW
 376         return __PACKAGE__->can("_${name}")->(@_);
 377     };
 378
 379     no strict 'refs';
 380     *$name = $fun;
 381 }
 382
 383 sub _customize_request {
 384     my $request = shift;
 385     my $extra_env = shift;
 386     my $opts = pop(@_) || {};
 387     $opts = {} unless ref($opts) eq 'HASH';
 388     if ( my $host = exists $opts->{host} ? $opts->{host} : $default_host  ) {
 389         $request->header( 'Host' => $host );
 390     }
 391
 392     if (my $extra = $opts->{extra_env}) {
 393         @{ $extra_env }{keys %{ $extra }} = values %{ $extra };
 394     }
 395 }
 396
 397 =head2 action_ok($url [, $test_name ])
 398
 399 Fetches the given URL and checks that the request was successful. An optional
 400 second argument can be given to specify the name of the test.
 401
 402 =head2 action_redirect($url [, $test_name ])
 403
 404 Fetches the given URL and checks that the request was a redirect. An optional
 405 second argument can be given to specify the name of the test.
 406
 407 =head2 action_notfound($url [, $test_name ])
 408
 409 Fetches the given URL and checks that the request was not found. An optional
 410 second argument can be given to specify the name of the test.
 411
 412 =head2 content_like( $url, $regexp [, $test_name ] )
 413
 414 Fetches the given URL and returns whether the content matches the regexp. An
 415 optional third argument can be given to specify the name of the test.
 416
 417 =head2 contenttype_is($url, $type [, $test_name ])
 418
 419 Verify the given URL has a content type of $type and optionally specify a test name.
 420
 421 =head1 SEE ALSO
 422
 423 L<Catalyst>, L<Test::WWW::Mechanize::Catalyst>,
 424 L<Test::WWW::Selenium::Catalyst>, L<Test::More>, L<HTTP::Request::Common>
 425
 426 =head1 AUTHORS
 427
 428 Catalyst Contributors, see Catalyst.pm
 429
 430 =head1 COPYRIGHT
 431
 432 This library is free software. You can redistribute it and/or modify it under
 433 the same terms as Perl itself.
 434
 435 =begin Pod::Coverage
 436
 437 local_request
 438
 439 remote_request
 440
 441 =end Pod::Coverage
 442
 443 =cut
 444
 445 1;