1 package Catalyst::Engine::Test;
4 use base 'Catalyst::Engine';
8 use HTTP::Headers::Util 'split_header_words';
14 __PACKAGE__->mk_accessors(qw/lwp/);
16 Class::Struct::struct 'Catalyst::Engine::Test::LWP' => {
17 request => 'HTTP::Request',
18 response => 'HTTP::Response',
25 Catalyst::Engine::Test - Catalyst Test Engine
29 A script using the Catalyst::Engine::Test module might look like:
34 $ENV{CATALYST_ENGINE} = 'Test';
38 use lib '/path/to/MyApp/lib';
41 MyApp->run('/a/path');
45 This is the Catalyst engine specialized for testing.
47 =head1 OVERLOADED METHODS
49 This class overloads some methods from C<Catalyst::Engine>.
53 =item $c->finalize_headers
57 sub finalize_headers {
60 $c->lwp->response->code( $c->response->status || 200 );
62 for my $name ( $c->response->headers->header_field_names ) {
63 $c->lwp->response->push_header( $name => [ $c->response->header($name) ] );
66 while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
67 my $cookie = CGI::Cookie->new(
69 -value => $cookie->{value},
70 -expires => $cookie->{expires},
71 -domain => $cookie->{domain},
72 -path => $cookie->{path},
73 -secure => $cookie->{secure} || 0
76 $c->lwp->response->header( 'Set-Cookie' => $cookie->as_string );
80 =item $c->finalize_output
86 $c->lwp->response->content_ref( \$c->response->{output} );
89 =item $c->prepare_connection
93 sub prepare_connection {
95 $c->req->hostname( $c->lwp->hostname );
96 $c->req->address( $c->lwp->address );
99 =item $c->prepare_cookies
103 sub prepare_cookies {
106 if ( my $header = $c->request->header('Cookie') ) {
107 $c->req->cookies( { CGI::Cookie->parse($header) } );
111 =item $c->prepare_headers
115 sub prepare_headers {
117 $c->req->method( $c->lwp->request->method );
118 $c->req->headers( $c->lwp->request->headers );
121 =item $c->prepare_parameters
125 sub prepare_parameters {
129 my $request = $c->lwp->request;
131 push( @params, $request->uri->query_form );
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 );
139 if ( $request->content_type eq 'multipart/form-data' ) {
141 for my $part ( $request->parts ) {
143 my $disposition = $part->header('Content-Disposition');
144 my %parameters = @{ ( split_header_words($disposition) )[0] };
146 if ( $parameters{filename} ) {
148 my $fh = IO::File->new_tmpfile;
149 $fh->write( $part->content ) or die $!;
150 $fh->seek( SEEK_SET, 0 ) or die $!;
152 $c->req->uploads->{ $parameters{filename} } = {
154 size => ( stat $fh )[7],
155 type => $part->content_type
158 push( @params, $parameters{filename}, $fh );
161 push( @params, $parameters{name}, $part->content );
166 my $parameters = $c->req->parameters;
168 while ( my ( $name, $value ) = splice( @params, 0, 2 ) ) {
170 if ( exists $parameters->{$name} ) {
171 for ( $parameters->{$name} ) {
172 $_ = [$_] unless ref($_) eq "ARRAY";
177 $parameters->{$name} = $value;
182 =item $c->prepare_path
191 my $scheme = $c->lwp->request->uri->scheme;
192 my $host = $c->lwp->request->uri->host;
193 my $port = $c->lwp->request->uri->port;
196 $base->scheme($scheme);
200 $base = $base->canonical->as_string;
203 my $path = $c->lwp->request->uri->path || '/';
204 $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
207 $c->req->base($base);
208 $c->req->path($path);
211 =item $c->prepare_request($r)
215 sub prepare_request {
216 my ( $c, $lwp ) = @_;
220 =item $c->prepare_uploads
224 sub prepare_uploads {
234 my $request = shift || '/';
236 unless ( ref $request ) {
238 my $uri = ( $request =~ m/http/i )
240 : URI->new( 'http://localhost' . $request );
242 $request = $uri->canonical;
245 unless ( ref $request eq 'HTTP::Request' ) {
246 $request = HTTP::Request->new( 'GET', $request );
249 my $lwp = Catalyst::Engine::Test::LWP->new(
250 address => '127.0.0.1',
251 hostname => 'localhost',
253 response => HTTP::Response->new
256 $class->handler($lwp);
258 return $lwp->response;
269 Sebastian Riedel, C<sri@cpan.org>
270 Christian Hansen, C<ch@ngmedia.com>
274 This program is free software, you can redistribute it and/or modify it under
275 the same terms as Perl itself.