- Fixed #15999 return a 500 response when message is empty, reported by Chris Dolan...

- Fixed Status header bug
- Bumped HTTP::Response requirement to 1.53 and drop our own message parsing.

diff --git a/Changes b/Changes
index 3b4e73a..7ee0f5c 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,10 +1,17 @@
 This file documents the revision history for Perl extension HTTP::Request::AsCGI.
 
-0.3  2005-11-18 00:00:00 2005
-    - silence uninitialized warnings when restoring %ENV
+0.4  2006-01-06 00:00:00 2005
+    - Fixed #15999 return a 500 response when message is empty, reported by Chris Dolan <cdolan@cpan.org>
+    - Fixed Status header bug
+    - Bumped HTTP::Response requirement to 1.53 and drop our own message parsing.
+
+0.3  2006-01-06 00:00:00 2005
+    - Silence uninitialized warnings when restoring %ENV
+    - Fixed dup and restore of STDIN.
 
 0.2  2005-10-31 00:55:00 2005
-    - added test for response.
+    - Added test for response.
 
 0.1  2005-10-21 00:00:00 2005
-    - first release.
+    - First release.
+

diff --git a/Makefile.PL b/Makefile.PL
index eda9759..734551f 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -9,7 +9,7 @@ WriteMakefile(
         Carp             => 0,
         Class::Accessor  => 0,        
         HTTP::Request    => 0,
-        HTTP::Response   => 0,
+        HTTP::Response   => 1.53,
         IO::File         => 0,
         Test::More       => 0
     }

diff --git a/lib/HTTP/Request/AsCGI.pm b/lib/HTTP/Request/AsCGI.pm
index f9ff8a3..a397b12 100644 (file)
--- a/lib/HTTP/Request/AsCGI.pm
+++ b/lib/HTTP/Request/AsCGI.pm
@@ -6,21 +6,22 @@ use bytes;
 use base 'Class::Accessor::Fast';
 
 use Carp;
+use HTTP::Response;
 use IO::Handle;
 use IO::File;
 
 __PACKAGE__->mk_accessors(qw[ enviroment request stdin stdout stderr ]);
 
-our $VERSION = 0.3;
+our $VERSION = 0.4;
 
 sub new {
     my $class   = shift;
     my $request = shift;
-    
+
     unless ( @_ % 2 == 0 && eval { $request->isa('HTTP::Request') } ) {
         croak(qq/usage: $class->new( \$request [, key => value] )/);
     }
-    
+
     my $self = $class->SUPER::new( { restored => 0, setuped => 0 } );
     $self->request($request);
     $self->stdin( IO::File->new_tmpfile );
@@ -32,7 +33,7 @@ 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;
 
     my $enviroment = {
@@ -91,7 +92,7 @@ sub setup {
           or croak("Can't seek stdin handle: $!");
     }
 
-    open( $self->{restore}->{stdin}, '>&', STDIN->fileno )
+    open( $self->{restore}->{stdin}, '<&', STDIN->fileno )
       or croak("Can't dup stdin: $!");
 
     open( STDIN, '<&=', $self->stdin->fileno )
@@ -127,10 +128,10 @@ sub setup {
         no warnings 'uninitialized';
         %ENV = %{ $self->enviroment };
     }
-    
+
     if ( $INC{'CGI.pm'} ) {
         CGI::initialize_globals();
-    }    
+    }
 
     $self->{setuped}++;
 
@@ -142,66 +143,72 @@ sub response {
 
     return undef unless $self->stdout;
 
-    require HTTP::Response;
-
     seek( $self->stdout, 0, SEEK_SET )
       or croak("Can't seek stdout handle: $!");
 
-    my $message;
+    my $headers;
     while ( my $line = $self->stdout->getline ) {
-        $message .= $line;
-        last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
+        $headers .= $line;
+        last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
     }
 
-    unless ( $message =~ /^HTTP/ ) {
-        $message = "HTTP/1.1 200 OK\x0d\x0a" . $message;
+    unless ( defined $headers ) {
+        $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
     }
 
-    my $response = HTTP::Response->new;
-    my @headers  = split( /\x0d?\x0a/, $message );
-    my $status   = shift(@headers);
-
-    unless ( $status =~ s/^(HTTP\/\d\.\d) (\d{3}) (.*)$// ) {
-        croak( "Invalid Status-Line: '$status'" );
+    unless ( $headers =~ /^HTTP/ ) {
+        $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
     }
 
-    $response->protocol($1);
-    $response->code($2);
-    $response->message($3);
+    my $response = HTTP::Response->parse($headers);
+    $response->date( time() ) unless $response->date;
 
-    my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
+    my $message = $response->message;
+    my $status  = $response->header('Status');
 
-    foreach my $header (@headers) {
+    if ( $message && $message =~ /^(.+)\x0d$/ ) {
+        $response->message($1);
+    }
 
-        unless( $header =~ s/^($token):[\t ]*// ) {
-            croak( "Invalid header field name : '$header'" );
-        }
+    if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
 
-        $response->push_header( $1 => $header );
-    }    
+        my $code    = $1;
+        my $message = $2 || HTTP::Status::status_message($code);
 
-    if ( my $code = $response->header('Status') ) {
         $response->code($code);
-        $response->message( HTTP::Status::status_message($code) );
+        $response->message($message);
     }
 
-    $response->headers->date( time() );
+    if ( $response->code == 500 && !$response->content ) {
+
+        $response->content( $response->error_as_HTML );
+        $response->content_type('text/html');
+
+        return $response;
+    }
 
     if ($callback) {
+
+        my $handle = $self->stdout;
+
         $response->content( sub {
-            if ( $self->stdout->read( my $buffer, 4096 ) ) {
+
+            if ( $handle->read( my $buffer, 4096 ) ) {
                 return $buffer;
             }
+
             return undef;
         });
     }
     else {
+
         my $length = 0;
+
         while ( $self->stdout->read( my $buffer, 4096 ) ) {
             $length += length($buffer);
             $response->add_content($buffer);
         }
-        
+
         if ( $length && !$response->content_length ) {
             $response->content_length($length);
         }
@@ -212,13 +219,13 @@ sub response {
 
 sub restore {
     my $self = shift;
-    
+
     {
         no warnings 'uninitialized';
         %ENV = %{ $self->{restore}->{enviroment} };
     }
 
-    open( STDIN, '>&', $self->{restore}->{stdin} )
+    open( STDIN, '<&', $self->{restore}->{stdin} )
       or croak("Can't restore stdin: $!");
 
     sysseek( $self->stdin, 0, SEEK_SET )

diff --git a/t/06response.t b/t/06response.t
index 26de31d..f3f9891 100644 (file)
--- a/t/06response.t
+++ b/t/06response.t
@@ -1,6 +1,6 @@
 #!perl
 
-use Test::More tests => 8;
+use Test::More tests => 9;
 
 use strict;
 use warnings;
@@ -17,9 +17,9 @@ my $response;
 
     $c->setup;
     
-    print "HTTP/1.0 200 OK\n";
     print "Content-Type: text/plain\n";
-    print "Status: 200\n";
+    print "Status: 200 Yay\n";
+    print "Date: Thu, 19 Jan 2006 14:08:18 GMT\n";
     print "X-Field: 1\n";
     print "X-Field: 2\n";
     print "\n";
@@ -30,9 +30,10 @@ my $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->message, 'Yay', 'Response Message' );
+is( $response->protocol, 'HTTP/1.1', '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( $response->header('Date'), 'Thu, 19 Jan 2006 14:08:18 GMT', 'Response Date' );
 is_deeply( [ $response->header('X-Field') ], [ 1, 2 ], 'Response Header X-Field' );

diff --git a/t/08error.t b/t/08error.t
new file mode 100644 (file)
index 0000000..18b6065
--- /dev/null
+++ b/t/08error.t
@@ -0,0 +1,28 @@
+#!perl
+
+use Test::More tests => 6;
+
+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;
+
+    $response = $c->restore->response;
+}
+
+isa_ok( $response, 'HTTP::Response' );
+is( $response->code, 500, 'Response Code' );
+is( $response->message, 'Internal Server Error', 'Response Message' );
+is( $response->protocol, 'HTTP/1.1', 'Response Protocol' );
+is( $response->content_type, 'text/html', 'Response Content-Type' );
+ok( length($response->content) > 0, 'Response Content' );