lib/Catalyst/Engine/Test.pm

   1 package Catalyst::Engine::Test;
   2
   3 use strict;
   4 use base 'Catalyst::Engine::CGI';
   5 use HTTP::Request;
   6 use HTTP::Response;
   7 use HTTP::Status;
   8 use NEXT;
   9
  10 =head1 NAME
  11
  12 Catalyst::Engine::Test - Catalyst Test Engine
  13
  14 =head1 SYNOPSIS
  15
  16 A script using the Catalyst::Engine::Test module might look like:
  17
  18     #!/usr/bin/perl -w
  19
  20     BEGIN {
  21        $ENV{CATALYST_ENGINE} = 'Test';
  22     }
  23
  24     use strict;
  25     use lib '/path/to/MyApp/lib';
  26     use MyApp;
  27
  28     MyApp->run('/a/path');
  29
  30 =head1 DESCRIPTION
  31
  32 This is the Catalyst engine specialized for testing.
  33
  34 =head1 OVERLOADED METHODS
  35
  36 This class overloads some methods from C<Catalyst::Engine::CGI>.
  37
  38 =over 4
  39
  40 =item finalize_headers
  41
  42 =cut
  43
  44 sub finalize_headers {
  45     my ( $self, $c ) = @_;
  46     my $protocol = $c->request->protocol;
  47     my $status   = $c->response->status;
  48     my $message  = status_message($status);
  49     print "$protocol $status $message\n";
  50     $c->response->headers->date(time);
  51     $self->NEXT::finalize_headers($c);
  52 }
  53
  54 =item $self->run($c)
  55
  56 =cut
  57
  58 sub run {
  59     my ( $self, $class, $request ) = @_;
  60
  61     # Construct request
  62     unless ( ref $request ) {
  63         if ( $request =~ m/http/i ) {
  64             $request = URI->new($request)->canonical;
  65         }
  66         else {
  67             $request = URI->new( 'http://localhost' . $request )->canonical;
  68         }
  69     }
  70     unless ( ref $request eq 'HTTP::Request' ) {
  71         $request = HTTP::Request->new( 'GET', $request );
  72     }
  73
  74     $request->header(
  75         'Host' => sprintf( '%s:%d', $request->uri->host, $request->uri->port )
  76     );
  77
  78     # We emulate CGI
  79     local %ENV = (
  80         PATH_INFO    => $request->uri->path  || '',
  81         QUERY_STRING => $request->uri->query || '',
  82         REMOTE_ADDR  => '127.0.0.1',
  83         REMOTE_HOST  => 'localhost',
  84         REQUEST_METHOD  => $request->method,
  85         SERVER_NAME     => 'localhost',
  86         SERVER_PORT     => $request->uri->port,
  87         SERVER_PROTOCOL => 'HTTP/1.1',
  88         %ENV,
  89     );
  90
  91     # Headers
  92     for my $header ( $request->header_field_names ) {
  93         my $name = uc $header;
  94         $name = 'COOKIE' if $name eq 'COOKIES';
  95         $name =~ tr/-/_/;
  96         $name = 'HTTP_' . $name
  97           unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/;
  98         my $value = $request->header($header);
  99         if ( exists $ENV{$name} ) {
 100             $ENV{$name} .= "; $value";
 101         }
 102         else {
 103             $ENV{$name} = $value;
 104         }
 105     }
 106
 107     # STDIN
 108     local *STDIN;
 109     my $input = $request->content;
 110     open STDIN, '<', \$input;
 111
 112     # STDOUT
 113     local *STDOUT;
 114     my $output = '';
 115     open STDOUT, '>', \$output;
 116
 117     # Process
 118     $class->handle_request;
 119
 120     # Response
 121     return HTTP::Response->parse($output);
 122 }
 123
 124 =item $self->read_chunk($c, $buffer, $length)
 125
 126 =cut
 127
 128 sub read_chunk { shift; shift; *STDIN->read(@_); }
 129
 130 =back
 131
 132 =head1 SEE ALSO
 133
 134 L<Catalyst>.
 135
 136 =head1 AUTHORS
 137
 138 Sebastian Riedel, <sri@cpan.org>
 139
 140 Christian Hansen, <ch@ngmedia.com>
 141
 142 Andy Grundman, <andy@hybridized.org>
 143
 144 =head1 COPYRIGHT
 145
 146 This program is free software, you can redistribute it and/or modify it under
 147 the same terms as Perl itself.
 148
 149 =cut
 150
 151 1;