[Catalyst-commits] r14038 - in HTTP-Request-AsCGI/trunk: . lib/HTTP/Request t

[rbuels at dev.catalyst.perl.org]

Author: rbuels
Date: 2011-06-08 22:30:19 +0000 (Wed, 08 Jun 2011)
New Revision: 14038

Modified:
   HTTP-Request-AsCGI/trunk/Changes
   HTTP-Request-AsCGI/trunk/lib/HTTP/Request/AsCGI.pm
   HTTP-Request-AsCGI/trunk/t/06response.t
Log:
fix content-length for  CGI scripts that don't print any headers

Modified: HTTP-Request-AsCGI/trunk/Changes
===================================================================
--- HTTP-Request-AsCGI/trunk/Changes	2011-06-08 22:25:27 UTC (rev 14037)
+++ HTTP-Request-AsCGI/trunk/Changes	2011-06-08 22:30:19 UTC (rev 14038)
@@ -1,5 +1,6 @@
 This file documents the revision history for Perl extension HTTP::Request::AsCGI.
 
+    - fix content-length for CGI scripts that don't print any headers (rbuels)
     - Fixed RT#46653 by localising %ENV in the test so that it can't be
       broken from outside.
     - Fixed tests on perl <= 5.6.2 by skipping if Encode is not installed.

Modified: HTTP-Request-AsCGI/trunk/lib/HTTP/Request/AsCGI.pm
===================================================================
--- HTTP-Request-AsCGI/trunk/lib/HTTP/Request/AsCGI.pm	2011-06-08 22:25:27 UTC (rev 14037)
+++ HTTP-Request-AsCGI/trunk/lib/HTTP/Request/AsCGI.pm	2011-06-08 22:30:19 UTC (rev 14038)
@@ -236,7 +236,7 @@
     }
     else {
 
-        my $length = 0;
+        my $length = defined $response->content ? length( $response->content ) : 0;
 
         while ( $self->stdout->read( my $buffer, 4096 ) ) {
             $length += length($buffer);

Modified: HTTP-Request-AsCGI/trunk/t/06response.t
===================================================================
--- HTTP-Request-AsCGI/trunk/t/06response.t	2011-06-08 22:25:27 UTC (rev 14037)
+++ HTTP-Request-AsCGI/trunk/t/06response.t	2011-06-08 22:30:19 UTC (rev 14038)
@@ -1,6 +1,6 @@
 #!perl
 
-use Test::More tests => 9;
+use Test::More tests => 16;
 
 use strict;
 use warnings;
@@ -16,7 +16,7 @@
     my $c = HTTP::Request::AsCGI->new($r);
 
     $c->setup;
-    
+
     print "Content-Type: text/plain\n";
     print "Status: 200 Yay\n";
     print "Date: Thu, 19 Jan 2006 14:08:18 GMT\n";
@@ -37,3 +37,24 @@
 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' );
+
+
+# test with a crappy cgi that doesn't actually print any headers.  actually works
+{
+    my $r = HTTP::Request->new( GET => 'http://www.host.com/' );
+    my $c = HTTP::Request::AsCGI->new($r);
+
+    $c->setup;
+
+    print "Look at me I am crappy and don't have any headers.";
+
+    $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.1', 'Response Protocol' );
+is( $response->content, "Look at me I am crappy and don't have any headers.", 'Response Content' );
+is( $response->content_length, 50, 'Response Content-Length is right!' );
+is( $response->content_type, '', 'Response Content-Type is blank' );