lib/Catalyst/Test.pm

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