From: Christian Hansen Date: Fri, 28 Oct 2005 12:32:29 +0000 (+0000) Subject: Improved tests X-Git-Tag: v1.0~42 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FHTTP-Request-AsCGI.git;a=commitdiff_plain;h=ca38286cea88a2f520b48043da5ff2aab89bc1dd Improved tests --- diff --git a/Changes b/Changes index 3dc7261..ab37ea5 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,7 @@ This file documents the revision history for Perl extension HTTP::Request::AsCGI. -0.01 2005-10-21 00:00:00 2005 - - first release +0.2 2005-10-28 00:00:00 2005 + - added test for response. + +0.1 2005-10-21 00:00:00 2005 + - first release. diff --git a/Makefile.PL b/Makefile.PL index 7d0fbb6..eda9759 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -7,9 +7,10 @@ WriteMakefile( VERSION_FROM => 'lib/HTTP/Request/AsCGI.pm', PREREQ_PM => { Carp => 0, - Class::Accessor => 0, + Class::Accessor => 0, HTTP::Request => 0, HTTP::Response => 0, - IO::File => 0 + IO::File => 0, + Test::More => 0 } ); diff --git a/examples/mechanize.pl b/examples/mechanize.pl index d74f2df..774ace3 100644 --- a/examples/mechanize.pl +++ b/examples/mechanize.pl @@ -20,6 +20,16 @@ sub cgi { return $self->{cgi}; } +sub env { + my $self = shift; + + if ( @_ ) { + $self->{env} = { @_ }; + } + + return %{ $self->{env} || {} }; +} + sub _make_request { my ( $self, $request ) = @_; @@ -27,7 +37,8 @@ sub _make_request { $self->cookie_jar->add_cookie_header($request); } - my $c = HTTP::Request::AsCGI->new($request)->setup; + my %e = $self->env; + my $c = HTTP::Request::AsCGI->new( $request, %e )->setup; eval { $self->cgi->() }; @@ -36,7 +47,9 @@ sub _make_request { if ( $@ ) { $response = HTTP::Response->new(500); $response->date( time() ); + $response->header( 'X-Error' => $@ ); $response->content( $response->error_as_HTML ); + $response->content_type('text/html'); } else { $response = $c->restore->response; diff --git a/lib/HTTP/Request/AsCGI.pm b/lib/HTTP/Request/AsCGI.pm index 43ffaab..226420c 100644 --- a/lib/HTTP/Request/AsCGI.pm +++ b/lib/HTTP/Request/AsCGI.pm @@ -11,7 +11,7 @@ use IO::File; __PACKAGE__->mk_accessors(qw[ enviroment request stdin stdout stderr ]); -our $VERSION = 0.1; +our $VERSION = 0.2; sub new { my $class = shift; @@ -20,14 +20,11 @@ sub new { unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) { croak(qq/usage: $class->new( \$request [, key => value] )/); } - - my $self = { - request => $request, - restored => 0, - setuped => 0, - stdin => IO::File->new_tmpfile, - stdout => IO::File->new_tmpfile - }; + + my $self = $class->SUPER::new( { restored => 0, setuped => 0 } ); + $self->request($request); + $self->stdin( IO::File->new_tmpfile ); + $self->stdout( IO::File->new_tmpfile ); my $host = $request->header('Host'); my $uri = $request->uri->clone; @@ -35,8 +32,10 @@ sub new { $uri->host('localhost') unless $uri->host; $uri->port(80) unless $uri->port; $uri->host_port($host) unless !$host || ( $host eq $uri->host_port ); + + $uri = $uri->canonical; - $self->{enviroment} = { + my $enviroment = { GATEWAY_INTERFACE => 'CGI/1.1', HTTP_HOST => $uri->host_port, HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875 @@ -50,23 +49,30 @@ sub new { REMOTE_ADDR => '127.0.0.1', REMOTE_HOST => 'localhost', REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875 - REQUEST_URI => $uri->path_query || '/', # not in RFC 3875 + REQUEST_URI => $uri->path_query, # not in RFC 3875 REQUEST_METHOD => $request->method, @_ }; foreach my $field ( $request->headers->header_field_names ) { - my $key = uc($field); + my $key = uc("HTTP_$field"); $key =~ tr/-/_/; - $key = 'HTTP_' . $key unless $field =~ /^Content-(Length|Type)$/; + $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/; - unless ( exists $self->{enviroment}->{$key} ) { - $self->{enviroment}->{$key} = $request->headers->header($field); + unless ( exists $enviroment->{$key} ) { + $enviroment->{$key} = $request->headers->header($field); } } - return $class->SUPER::new($self); + unless ( $enviroment->{SCRIPT_NAME} eq '/' && $enviroment->{PATH_INFO} ) { + $enviroment->{PATH_INFO} =~ s/^\Q$enviroment->{SCRIPT_NAME}\E/\//; + $enviroment->{PATH_INFO} =~ s/^\/+/\//; + } + + $self->enviroment($enviroment); + + return $self; } sub setup { @@ -74,14 +80,7 @@ sub setup { $self->{restore}->{enviroment} = {%ENV}; - open( $self->{restore}->{stdin}, '>&', STDIN->fileno ) - or croak("Can't dup stdin: $!"); - - open( STDIN, '<&=', $self->stdin->fileno ) - or croak("Can't open stdin: $!"); - binmode( $self->stdin ); - binmode( STDIN ); if ( $self->request->content_length ) { @@ -92,6 +91,14 @@ sub setup { or croak("Can't seek stdin handle: $!"); } + open( $self->{restore}->{stdin}, '>&', STDIN->fileno ) + or croak("Can't dup stdin: $!"); + + open( STDIN, '<&=', $self->stdin->fileno ) + or croak("Can't open stdin: $!"); + + binmode( STDIN ); + if ( $self->stdout ) { open( $self->{restore}->{stdout}, '>&', STDOUT->fileno ) @@ -297,7 +304,7 @@ Provides a convinient way of setting up an CGI enviroment from a HTTP::Request. =item new ( $request [, key => value ] ) Contructor, first argument must be a instance of HTTP::Request -followed by optional pairs of environment keys and values. +followed by optional pairs of environment key and value. =item enviroment diff --git a/t/05env.t b/t/05env.t index 782a123..e77ed92 100644 --- a/t/05env.t +++ b/t/05env.t @@ -9,8 +9,9 @@ use IO::File; use HTTP::Request; use HTTP::Request::AsCGI; -my $r = HTTP::Request->new( GET => 'http://www.host.com/my/path/?a=1&b=2', [ 'X-Test' => 'Test' ] ); -my $c = HTTP::Request::AsCGI->new($r); +my $r = HTTP::Request->new( GET => 'http://www.host.com/cgi-bin/script.cgi/my/path/?a=1&b=2', [ 'X-Test' => 'Test' ] ); +my %e = ( SCRIPT_NAME => '/cgi-bin/script.cgi' ); +my $c = HTTP::Request::AsCGI->new( $r, %e ); $c->stdout(undef); $c->setup; @@ -20,7 +21,7 @@ is( $ENV{HTTP_HOST}, 'www.host.com:80', 'HTTP_HOST' ); is( $ENV{HTTP_X_TEST}, 'Test', 'HTTP_X_TEST' ); is( $ENV{PATH_INFO}, '/my/path/', 'PATH_INFO' ); is( $ENV{QUERY_STRING}, 'a=1&b=2', 'QUERY_STRING' ); -is( $ENV{SCRIPT_NAME}, '/', 'SCRIPT_NAME' ); +is( $ENV{SCRIPT_NAME}, '/cgi-bin/script.cgi', 'SCRIPT_NAME' ); is( $ENV{REQUEST_METHOD}, 'GET', 'REQUEST_METHOD' ); is( $ENV{SERVER_NAME}, 'www.host.com', 'SERVER_NAME' ); is( $ENV{SERVER_PORT}, '80', 'SERVER_PORT' ); diff --git a/t/06response.t b/t/06response.t new file mode 100644 index 0000000..26de31d --- /dev/null +++ b/t/06response.t @@ -0,0 +1,38 @@ +#!perl + +use Test::More tests => 8; + +use strict; +use warnings; + +use IO::File; +use HTTP::Request; +use HTTP::Request::AsCGI; + +my $response; + +{ + my $r = HTTP::Request->new( GET => 'http://www.host.com/' ); + my $c = HTTP::Request::AsCGI->new($r); + + $c->setup; + + print "HTTP/1.0 200 OK\n"; + print "Content-Type: text/plain\n"; + print "Status: 200\n"; + print "X-Field: 1\n"; + print "X-Field: 2\n"; + print "\n"; + print "Hello!"; + + $response = $c->restore->response; +} + +isa_ok( $response, 'HTTP::Response' ); +is( $response->code, 200, 'Response Code' ); +is( $response->message, 'OK', 'Response Message' ); +is( $response->protocol, 'HTTP/1.0', 'Response Protocol' ); +is( $response->content, 'Hello!', 'Response Content' ); +is( $response->content_length, 6, 'Response Content-Length' ); +is( $response->content_type, 'text/plain', 'Response Content-Type' ); +is_deeply( [ $response->header('X-Field') ], [ 1, 2 ], 'Response Header X-Field' );