lib/Catalyst/Engine/Test.pm

   1 package Catalyst::Engine::Test;
   2
   3 use strict;
   4 use base 'Catalyst::Engine::CGI';
   5 use Catalyst::Utils;
   6 use HTTP::Headers;
   7 use HTTP::Response;
   8 use HTTP::Status;
   9 use NEXT;
  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>.
  38
  39 =over 4
  40
  41 =item finalize_headers
  42
  43 =cut
  44
  45 sub finalize_headers {
  46     my ( $self, $c ) = @_;
  47     my $protocol = $c->request->protocol;
  48     my $status   = $c->response->status;
  49     my $message  = status_message($status);
  50     print "$protocol $status $message\n";
  51     $c->response->headers->date(time);
  52     $self->NEXT::finalize_headers($c);
  53 }
  54
  55 =item $self->run($c)
  56
  57 =cut
  58
  59 sub run {
  60     my ( $self, $class, $request ) = @_;
  61
  62     $request = Catalyst::Utils::request($request);
  63
  64     $request->header(
  65         'Host' => sprintf( '%s:%d', $request->uri->host, $request->uri->port )
  66     );
  67
  68     # We emulate CGI
  69     local %ENV = (
  70         PATH_INFO    => $request->uri->path  || '',
  71         QUERY_STRING => $request->uri->query || '',
  72         REMOTE_ADDR  => '127.0.0.1',
  73         REMOTE_HOST  => 'localhost',
  74         REQUEST_METHOD  => $request->method,
  75         SERVER_NAME     => 'localhost',
  76         SERVER_PORT     => $request->uri->port,
  77         SERVER_PROTOCOL => 'HTTP/1.1',
  78         %ENV,
  79     );
  80
  81     # Headers
  82     for my $header ( $request->header_field_names ) {
  83         my $name = uc $header;
  84         $name = 'COOKIE' if $name eq 'COOKIES';
  85         $name =~ tr/-/_/;
  86         $name = 'HTTP_' . $name
  87           unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/;
  88         my $value = $request->header($header);
  89         if ( exists $ENV{$name} ) {
  90             $ENV{$name} .= "; $value";
  91         }
  92         else {
  93             $ENV{$name} = $value;
  94         }
  95     }
  96
  97     # STDIN
  98     local *STDIN;
  99     my $input = $request->content;
 100     open STDIN, '<', \$input;
 101
 102     # STDOUT
 103     local *STDOUT;
 104     my $output = '';
 105     open STDOUT, '>', \$output;
 106
 107     # Process
 108     $class->handle_request;
 109
 110     # Response
 111     return HTTP::Response->parse($output);
 112 }
 113
 114 =item $self->read_chunk($c, $buffer, $length)
 115
 116 =cut
 117
 118 sub read_chunk { shift; shift; *STDIN->read(@_); }
 119
 120 =back
 121
 122 =head1 SEE ALSO
 123
 124 L<Catalyst>.
 125
 126 =head1 AUTHORS
 127
 128 Sebastian Riedel, <sri@cpan.org>
 129
 130 Christian Hansen, <ch@ngmedia.com>
 131
 132 Andy Grundman, <andy@hybridized.org>
 133
 134 =head1 COPYRIGHT
 135
 136 This program is free software, you can redistribute it and/or modify it under
 137 the same terms as Perl itself.
 138
 139 =cut
 140
 141 1;