use strict;
use UNIVERSAL::require;
+use IO::File;
+use HTTP::Request;
use HTTP::Response;
use Socket;
use URI;
+require Catalyst;
+
my $class;
$ENV{CATALYST_ENGINE} = 'CGI';
$ENV{CATALYST_TEST} = 1;
=head1 SYNOPSIS
+ # Helper
+ script/cgi-server.pl
+ script/server.pl
+ script/test.pl
+
# Tests
use Catalyst::Test 'TestApp';
request('index.html');
sub import {
my $self = shift;
- $class = shift;
- $class->require;
- if ( ( caller(0) )[1] eq '-e' ) {
- die qq/Couldn't load "$class", "$@"/ if $@;
+ if ( $class = shift ) {
+ $class->require;
+ unless ( $INC{'Test/Builder.pm'} ) {
+ die qq/Couldn't load "$class", "$@"/ if $@;
+ }
+ my $caller = caller(0);
+ no strict 'refs';
+ *{"$caller\::request"} = \&request;
+ *{"$caller\::get"} = sub { request(@_)->content };
}
- my $caller = caller(0);
- no strict 'refs';
- *{"$caller\::request"} = \&request;
- *{"$caller\::get"} = sub { request(@_)->content };
}
sub request {
- my $uri = shift;
- local *STDOUT;
+ my $request = shift;
+ unless ( ref $request ) {
+ $request = URI->new( $request, 'http' );
+ }
+ unless ( ref $request eq 'HTTP::Request' ) {
+ $request = HTTP::Request->new( 'GET', $request );
+ }
+ local ( *STDIN, *STDOUT );
+ my %clean = %ENV;
my $output = '';
- open STDOUT, '>', \$output;
- $uri = URI->new($uri);
- my %clean = %ENV;
- $ENV{REQUEST_METHOD} ||= 'GET';
- $ENV{HTTP_HOST} ||= $uri->authority || 'localhost';
- $ENV{SCRIPT_NAME} ||= $uri->path || '/';
- $ENV{QUERY_STRING} ||= $uri->query || '';
- $ENV{CONTENT_TYPE} ||= 'text/plain';
+ $ENV{CONTENT_TYPE} ||= $request->header('Content-Type') || '';
+ $ENV{CONTENT_LENGTH} ||= $request->header('Content-Length') || '';
+ $ENV{GATEWAY_INTERFACE} ||= 'CGI/1.1';
+ $ENV{HTTP_USER_AGENT} ||= 'Catalyst';
+ $ENV{HTTP_HOST} ||= $request->uri->host || 'localhost';
+ $ENV{QUERY_STRING} ||= $request->uri->query || '';
+ $ENV{REQUEST_METHOD} ||= $request->method;
+ $ENV{SCRIPT_NAME} ||= $request->uri->path || '/';
+ $ENV{SERVER_NAME} ||= $request->uri->host || 'localhost';
+ $ENV{SERVER_PORT} ||= $request->uri->port;
+ $ENV{SERVER_PROTOCOL} ||= 'HTTP/1.1';
+
+ for my $field ( $request->header_field_names ) {
+ if ( $field =~ /^Content-(Length|Type)$/ ) {
+ next;
+ }
+ $field =~ s/-/_/g;
+ $ENV{ 'HTTP_' . uc($field) } = $request->header($field);
+ }
+ if ( $request->content_length ) {
+ my $body = IO::File->new_tmpfile;
+ $body->print( $request->content ) or die $!;
+ $body->seek( 0, SEEK_SET ) or die $!;
+ open( STDIN, "<&=", $body->fileno )
+ or die("Failed to dup \$body: $!");
+ }
+ open( STDOUT, '>', \$output );
$class->handler;
%ENV = %clean;
return HTTP::Response->parse($output);
=cut
sub server {
- my $port = shift;
+ my ( $port, $script ) = @_;
# Listen
my $tcp = getprotobyname('tcp');
$ENV{REMOTE_ADDR} = $peeraddr;
$ENV{REMOTE_HOST} = $peername;
$ENV{QUERY_STRING} = $query_string || '';
- $ENV{CONTENT_TYPE} ||= 'text/plain';
+ $ENV{CONTENT_TYPE} ||= 'multipart/form-data';
$ENV{SERVER_SOFTWARE} ||= "Catalyst/$Catalyst::VERSION";
- $class->run;
+ $script ? print STDOUT `$script` : $class->run;
}
}