lib/Catalyst/Engine/Test.pm

   1 package Catalyst::Engine::Test;
   2
   3 use strict;
   4 use base 'Catalyst::Engine::CGI::NPH';
   5
   6 use HTTP::Request;
   7 use HTTP::Response;
   8 use IO::File;
   9 use URI;
  10
  11 =head1 NAME
  12
  13 Catalyst::Engine::Test - Catalyst Test Engine
  14
  15 =head1 SYNOPSIS
  16
  17 A script using the Catalyst::Engine::Test module might look like:
  18
  19     #!/usr/bin/perl -w
  20
  21     BEGIN {
  22        $ENV{CATALYST_ENGINE} = 'Test';
  23     }
  24
  25     use strict;
  26     use lib '/path/to/MyApp/lib';
  27     use MyApp;
  28
  29     MyApp->run('/a/path');
  30
  31 =head1 DESCRIPTION
  32
  33 This is the Catalyst engine specialized for testing.
  34
  35 =head1 OVERLOADED METHODS
  36
  37 This class overloads some methods from C<Catalyst::Engine::CGI::NPH>.
  38
  39 =over 4
  40
  41 =item $c->run
  42
  43 =cut
  44
  45 sub run {
  46     my $class   = shift;
  47     my $request = shift || '/';
  48
  49     unless ( ref $request ) {
  50         $request = URI->new( $request, 'http' );
  51     }
  52     unless ( ref $request eq 'HTTP::Request' ) {
  53         $request = HTTP::Request->new( 'GET', $request );
  54     }
  55
  56     local ( *STDIN, *STDOUT );
  57
  58     my %clean  = %ENV;
  59     my $output = '';
  60     $ENV{CONTENT_TYPE}   ||= $request->header('Content-Type')   || '';
  61     $ENV{CONTENT_LENGTH} ||= $request->header('Content-Length') || '';
  62     $ENV{GATEWAY_INTERFACE} ||= 'CGI/1.1';
  63     $ENV{HTTP_USER_AGENT}   ||= 'Catalyst';
  64     $ENV{HTTP_HOST}         ||= $request->uri->host || 'localhost';
  65     $ENV{QUERY_STRING}      ||= $request->uri->query || '';
  66     $ENV{REQUEST_METHOD}    ||= $request->method;
  67     $ENV{PATH_INFO}         ||= $request->uri->path || '/';
  68     $ENV{SCRIPT_NAME}       ||= '/';
  69     $ENV{SERVER_NAME}       ||= $request->uri->host || 'localhost';
  70     $ENV{SERVER_PORT}       ||= $request->uri->port;
  71     $ENV{SERVER_PROTOCOL}   ||= 'HTTP/1.1';
  72
  73     for my $field ( $request->header_field_names ) {
  74         if ( $field =~ /^Content-(Length|Type)$/ ) {
  75             next;
  76         }
  77         $field =~ s/-/_/g;
  78         $ENV{ 'HTTP_' . uc($field) } = $request->header($field);
  79     }
  80
  81     if ( $request->content_length ) {
  82         my $body = IO::File->new_tmpfile;
  83         $body->print( $request->content ) or die $!;
  84         $body->seek( 0, SEEK_SET ) or die $!;
  85         open( STDIN, "<&=", $body->fileno )
  86           or die("Failed to dup \$body: $!");
  87     }
  88
  89     open( STDOUT, '>', \$output );
  90     $class->handler;
  91     %ENV = %clean;
  92     return HTTP::Response->parse($output);
  93 }
  94
  95 =back
  96
  97 =head1 SEE ALSO
  98
  99 L<Catalyst>.
 100
 101 =head1 AUTHOR
 102
 103 Sebastian Riedel, C<sri@cpan.org>
 104 Christian Hansen, C<ch@ngmedia.com>
 105
 106 =head1 COPYRIGHT
 107
 108 This program is free software, you can redistribute it and/or modify it under
 109 the same terms as Perl itself.
 110
 111 =cut
 112
 113 1;