lib/Catalyst/Engine/Test.pm

   1 package Catalyst::Engine::Test;
   2
   3 use strict;
   4 use base 'Catalyst::Engine';
   5
   6 use CGI::Cookie;
   7 use Class::Struct ();
   8 use HTTP::Headers::Util 'split_header_words';
   9 use HTTP::Request;
  10 use HTTP::Response;
  11 use IO::File;
  12 use URI;
  13
  14 __PACKAGE__->mk_accessors(qw/lwp/);
  15
  16 Class::Struct::struct 'Catalyst::Engine::Test::LWP' => {
  17     request  => 'HTTP::Request',
  18     response => 'HTTP::Response',
  19     hostname => '$',
  20     address  => '$'
  21 };
  22
  23 =head1 NAME
  24
  25 Catalyst::Engine::Test - Catalyst Test Engine
  26
  27 =head1 SYNOPSIS
  28
  29 A script using the Catalyst::Engine::Test module might look like:
  30
  31     #!/usr/bin/perl -w
  32
  33     BEGIN {
  34        $ENV{CATALYST_ENGINE} = 'Test';
  35     }
  36
  37     use strict;
  38     use lib '/path/to/MyApp/lib';
  39     use MyApp;
  40
  41     MyApp->run('/a/path');
  42
  43 =head1 DESCRIPTION
  44
  45 This is the Catalyst engine specialized for testing.
  46
  47 =head1 OVERLOADED METHODS
  48
  49 This class overloads some methods from C<Catalyst::Engine>.
  50
  51 =over 4
  52
  53 =item $c->finalize_headers
  54
  55 =cut
  56
  57 sub finalize_headers {
  58     my $c = shift;
  59
  60     $c->lwp->response->code( $c->response->status || 200 );
  61
  62     for my $name ( $c->response->headers->header_field_names ) {
  63         $c->lwp->response->push_header( $name => [ $c->response->header($name) ] );
  64     }
  65
  66     while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
  67         my $cookie = CGI::Cookie->new(
  68             -name    => $name,
  69             -value   => $cookie->{value},
  70             -expires => $cookie->{expires},
  71             -domain  => $cookie->{domain},
  72             -path    => $cookie->{path},
  73             -secure  => $cookie->{secure} || 0
  74         );
  75
  76         $c->lwp->response->headers->push_header( 'Set-Cookie' => $cookie->as_string );
  77     }
  78 }
  79
  80 =item $c->finalize_output
  81
  82 =cut
  83
  84 sub finalize_output {
  85     my $c = shift;
  86     $c->lwp->response->content_ref( \$c->response->{output} );
  87 }
  88
  89 =item $c->prepare_connection
  90
  91 =cut
  92
  93 sub prepare_connection {
  94     my $c = shift;
  95     $c->req->hostname( $c->lwp->hostname );
  96     $c->req->address( $c->lwp->address );
  97 }
  98
  99 =item $c->prepare_cookies
 100
 101 =cut
 102
 103 sub prepare_cookies {
 104     my $c = shift;
 105
 106     if ( my $header = $c->request->header('Cookie') ) {
 107         $c->req->cookies( { CGI::Cookie->parse($header) } );
 108     }
 109 }
 110
 111 =item $c->prepare_headers
 112
 113 =cut
 114
 115 sub prepare_headers {
 116     my $c = shift;
 117     $c->req->method( $c->lwp->request->method );
 118     $c->req->headers( $c->lwp->request->headers );
 119 }
 120
 121 =item $c->prepare_parameters
 122
 123 =cut
 124
 125 sub prepare_parameters {
 126     my $c = shift;
 127
 128     my @params  = ();
 129     my $request = $c->lwp->request;
 130
 131     push( @params, $request->uri->query_form );
 132
 133     if ( $request->content_type eq 'application/x-www-form-urlencoded' ) {
 134         my $uri = URI->new('http:');
 135         $uri->query( $request->content );
 136         push( @params, $uri->query_form );
 137     }
 138
 139     if ( $request->content_type eq 'multipart/form-data' ) {
 140
 141         for my $part ( $request->parts ) {
 142
 143             my $disposition = $part->header('Content-Disposition');
 144             my %parameters  = @{ ( split_header_words($disposition) )[0] };
 145
 146             if ( $parameters{filename} ) {
 147
 148                 my $fh = IO::File->new_tmpfile;
 149                 $fh->write( $part->content ) or die $!;
 150                 $fh->seek( SEEK_SET, 0 ) or die $!;
 151
 152                 $c->req->uploads->{ $parameters{filename} } = {
 153                     fh   => $fh,
 154                     size => ( stat $fh )[7],
 155                     type => $part->content_type
 156                 };
 157
 158                 push( @params, $parameters{filename}, $fh );
 159             }
 160             else {
 161                 push( @params, $parameters{name}, $part->content );
 162             }
 163         }
 164     }
 165
 166     my $parameters = $c->req->parameters;
 167
 168     while ( my ( $name, $value ) = splice( @params, 0, 2 ) ) {
 169
 170         if ( exists $parameters->{$name} ) {
 171             for ( $parameters->{$name} ) {
 172                 $_ = [$_] unless ref($_) eq "ARRAY";
 173                 push( @$_, $value );
 174             }
 175         }
 176         else {
 177             $parameters->{$name} = $value;
 178         }
 179     }
 180 }
 181
 182 =item $c->prepare_path
 183
 184 =cut
 185
 186 sub prepare_path {
 187     my $c = shift;
 188
 189     my $base;
 190     {
 191         my $scheme = $c->lwp->request->uri->scheme;
 192         my $host   = $c->lwp->request->uri->host;
 193         my $port   = $c->lwp->request->uri->port;
 194
 195         $base = URI->new;
 196         $base->scheme($scheme);
 197         $base->host($host);
 198         $base->port($port);
 199
 200         $base = $base->canonical->as_string;
 201     }
 202
 203     my $path = $c->lwp->request->uri->path || '/';
 204     $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 205     $path =~ s/^\///;
 206
 207     $c->req->base($base);
 208     $c->req->path($path);
 209 }
 210
 211 =item $c->prepare_request($r)
 212
 213 =cut
 214
 215 sub prepare_request {
 216     my ( $c, $lwp ) = @_;
 217     $c->lwp($lwp);
 218 }
 219
 220 =item $c->prepare_uploads
 221
 222 =cut
 223
 224 sub prepare_uploads {
 225     my $c = shift;
 226 }
 227
 228 =item $c->run
 229
 230 =cut
 231
 232 sub run {
 233     my $class   = shift;
 234     my $request = shift || '/';
 235
 236     unless ( ref $request ) {
 237
 238         my $uri = ( $request =~ m/http/i )
 239           ? URI->new($request)
 240           : URI->new( 'http://localhost' . $request );
 241
 242         $request = $uri->canonical;
 243     }
 244
 245     unless ( ref $request eq 'HTTP::Request' ) {
 246         $request = HTTP::Request->new( 'GET', $request );
 247     }
 248
 249     my $host = sprintf( '%s:%d', $request->uri->host, $request->uri->port );
 250     $request->header( 'Host' => $host );
 251
 252     my $lwp = Catalyst::Engine::Test::LWP->new(
 253         address  => '127.0.0.1',
 254         hostname => 'localhost',
 255         request  => $request,
 256         response => HTTP::Response->new
 257     );
 258
 259     $lwp->response->date(time);
 260
 261     $class->handler($lwp);
 262
 263     return $lwp->response;
 264 }
 265
 266 =back
 267
 268 =head1 SEE ALSO
 269
 270 L<Catalyst>.
 271
 272 =head1 AUTHOR
 273
 274 Sebastian Riedel, C<sri@cpan.org>
 275 Christian Hansen, C<ch@ngmedia.com>
 276
 277 =head1 COPYRIGHT
 278
 279 This program is free software, you can redistribute it and/or modify it under
 280 the same terms as Perl itself.
 281
 282 =cut
 283
 284 1;