Added rawhandles option to bypass a Perl bug

diff --git a/Changes b/Changes
index 3b4e73a..f3299ae 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
 This file documents the revision history for Perl extension HTTP::Request::AsCGI.
 
+0.4
+    - Added rawhandles option to bypass a Perl bug
+
 0.3  2005-11-18 00:00:00 2005
     - silence uninitialized warnings when restoring %ENV
 

diff --git a/lib/HTTP/Request/AsCGI.pm b/lib/HTTP/Request/AsCGI.pm
index f9ff8a3..ae4bf1c 100644 (file)
--- a/lib/HTTP/Request/AsCGI.pm
+++ b/lib/HTTP/Request/AsCGI.pm
@@ -9,48 +9,47 @@ use Carp;
 use IO::Handle;
 use IO::File;
 
-__PACKAGE__->mk_accessors(qw[ enviroment request stdin stdout stderr ]);
+__PACKAGE__->mk_accessors(
+    qw[ enviroment request rawhandles 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 );
-    $self->stdout( IO::File->new_tmpfile );
 
     my $host = $request->header('Host');
     my $uri  = $request->uri->clone;
     $uri->scheme('http')    unless $uri->scheme;
     $uri->host('localhost') unless $uri->host;
     $uri->port(80)          unless $uri->port;
-    $uri->host_port($host)  unless !$host || ( $host eq $uri->host_port );
-    
+    $uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
+
     $uri = $uri->canonical;
 
     my $enviroment = {
         GATEWAY_INTERFACE => 'CGI/1.1',
         HTTP_HOST         => $uri->host_port,
-        HTTPS             => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF',  # not in RFC 3875
-        PATH_INFO         => $uri->path,
-        QUERY_STRING      => $uri->query || '',
-        SCRIPT_NAME       => '/',
-        SERVER_NAME       => $uri->host,
-        SERVER_PORT       => $uri->port,
-        SERVER_PROTOCOL   => $request->protocol || 'HTTP/1.1',
-        SERVER_SOFTWARE   => "HTTP-Request-AsCGI/$VERSION",
-        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_METHOD    => $request->method,
+        HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF',   # not in RFC 3875
+        PATH_INFO       => $uri->path,
+        QUERY_STRING    => $uri->query || '',
+        SCRIPT_NAME     => '/',
+        SERVER_NAME     => $uri->host,
+        SERVER_PORT     => $uri->port,
+        SERVER_PROTOCOL => $request->protocol || 'HTTP/1.1',
+        SERVER_SOFTWARE => "HTTP-Request-AsCGI/$VERSION",
+        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_METHOD  => $request->method,
         @_
     };
 
@@ -80,6 +79,15 @@ sub setup {
 
     $self->{restore}->{enviroment} = {%ENV};
 
+    if ( $self->rawhandles ) {
+        $self->stdin( \*STDIN );
+        $self->stdout( \*STDOUT );
+    }
+    else {
+        $self->stdin( IO::File->new_tmpfile );
+        $self->stdout( IO::File->new_tmpfile );
+    }
+
     binmode( $self->stdin );
 
     if ( $self->request->content_length ) {
@@ -91,46 +99,50 @@ sub setup {
           or croak("Can't seek stdin handle: $!");
     }
 
-    open( $self->{restore}->{stdin}, '>&', STDIN->fileno )
-      or croak("Can't dup stdin: $!");
+    unless ( $self->rawhandles ) {
 
-    open( STDIN, '<&=', $self->stdin->fileno )
-      or croak("Can't open stdin: $!");
+        open( $self->{restore}->{stdin}, '>&', STDIN->fileno )
+          or croak("Can't dup stdin: $!");
 
-    binmode( STDIN );
+        open( STDIN, '<&=', $self->stdin->fileno )
+          or croak("Can't open stdin: $!");
 
-    if ( $self->stdout ) {
+        binmode(STDIN);
 
-        open( $self->{restore}->{stdout}, '>&', STDOUT->fileno )
-          or croak("Can't dup stdout: $!");
+        if ( $self->stdout ) {
 
-        open( STDOUT, '>&=', $self->stdout->fileno )
-          or croak("Can't open stdout: $!");
+            open( $self->{restore}->{stdout}, '>&', STDOUT->fileno )
+              or croak("Can't dup stdout: $!");
 
-        binmode( $self->stdout );
-        binmode( STDOUT);
-    }
+            open( STDOUT, '>&=', $self->stdout->fileno )
+              or croak("Can't open stdout: $!");
+
+            binmode( $self->stdout );
+            binmode(STDOUT);
+        }
+
+        if ( $self->stderr ) {
 
-    if ( $self->stderr ) {
+            open( $self->{restore}->{stderr}, '>&', STDERR->fileno )
+              or croak("Can't dup stderr: $!");
 
-        open( $self->{restore}->{stderr}, '>&', STDERR->fileno )
-          or croak("Can't dup stderr: $!");
+            open( STDERR, '>&=', $self->stderr->fileno )
+              or croak("Can't open stderr: $!");
 
-        open( STDERR, '>&=', $self->stderr->fileno )
-          or croak("Can't open stderr: $!");
+            binmode( $self->stderr );
+            binmode(STDERR);
+        }
 
-        binmode( $self->stderr );
-        binmode( STDERR );
     }
 
     {
         no warnings 'uninitialized';
         %ENV = %{ $self->enviroment };
     }
-    
+
     if ( $INC{'CGI.pm'} ) {
         CGI::initialize_globals();
-    }    
+    }
 
     $self->{setuped}++;
 
@@ -162,7 +174,7 @@ sub response {
     my $status   = shift(@headers);
 
     unless ( $status =~ s/^(HTTP\/\d\.\d) (\d{3}) (.*)$// ) {
-        croak( "Invalid Status-Line: '$status'" );
+        croak("Invalid Status-Line: '$status'");
     }
 
     $response->protocol($1);
@@ -173,12 +185,12 @@ sub response {
 
     foreach my $header (@headers) {
 
-        unless( $header =~ s/^($token):[\t ]*// ) {
-            croak( "Invalid header field name : '$header'" );
+        unless ( $header =~ s/^($token):[\t ]*// ) {
+            croak("Invalid header field name : '$header'");
         }
 
         $response->push_header( $1 => $header );
-    }    
+    }
 
     if ( my $code = $response->header('Status') ) {
         $response->code($code);
@@ -188,12 +200,14 @@ sub response {
     $response->headers->date( time() );
 
     if ($callback) {
-        $response->content( sub {
-            if ( $self->stdout->read( my $buffer, 4096 ) ) {
-                return $buffer;
+        $response->content(
+            sub {
+                if ( $self->stdout->read( my $buffer, 4096 ) ) {
+                    return $buffer;
+                }
+                return undef;
             }
-            return undef;
-        });
+        );
     }
     else {
         my $length = 0;
@@ -201,7 +215,7 @@ sub response {
             $length += length($buffer);
             $response->add_content($buffer);
         }
-        
+
         if ( $length && !$response->content_length ) {
             $response->content_length($length);
         }
@@ -212,40 +226,44 @@ sub response {
 
 sub restore {
     my $self = shift;
-    
+
     {
         no warnings 'uninitialized';
         %ENV = %{ $self->{restore}->{enviroment} };
     }
 
-    open( STDIN, '>&', $self->{restore}->{stdin} )
-      or croak("Can't restore stdin: $!");
+    unless ( $self->rawhandles ) {
 
-    sysseek( $self->stdin, 0, SEEK_SET )
-      or croak("Can't seek stdin: $!");
+        open( STDIN, '>&', $self->{restore}->{stdin} )
+          or croak("Can't restore stdin: $!");
 
-    if ( $self->{restore}->{stdout} ) {
+        sysseek( $self->stdin, 0, SEEK_SET )
+          or croak("Can't seek stdin: $!");
 
-        STDOUT->flush
-          or croak("Can't flush stdout: $!");
+        if ( $self->{restore}->{stdout} ) {
 
-        open( STDOUT, '>&', $self->{restore}->{stdout} )
-          or croak("Can't restore stdout: $!");
+            STDOUT->flush
+              or croak("Can't flush stdout: $!");
 
-        sysseek( $self->stdout, 0, SEEK_SET )
-          or croak("Can't seek stdout: $!");
-    }
+            open( STDOUT, '>&', $self->{restore}->{stdout} )
+              or croak("Can't restore stdout: $!");
+
+            sysseek( $self->stdout, 0, SEEK_SET )
+              or croak("Can't seek stdout: $!");
+        }
 
-    if ( $self->{restore}->{stderr} ) {
+        if ( $self->{restore}->{stderr} ) {
 
-        STDERR->flush
-          or croak("Can't flush stderr: $!");
+            STDERR->flush
+              or croak("Can't flush stderr: $!");
 
-        open( STDERR, '>&', $self->{restore}->{stderr} )
-          or croak("Can't restore stderr: $!");
+            open( STDERR, '>&', $self->{restore}->{stderr} )
+              or croak("Can't restore stderr: $!");
+
+            sysseek( $self->stderr, 0, SEEK_SET )
+              or croak("Can't seek stderr: $!");
+        }
 
-        sysseek( $self->stderr, 0, SEEK_SET )
-          or croak("Can't seek stderr: $!");
     }
 
     $self->{restored}++;
@@ -316,6 +334,10 @@ Changing the hashref after setup has been called will have no effect.
 
 Setups the environment and descriptors.
 
+=item rawhandles
+
+Don't redefine STDIN/STDOUT/STDERR internally.
+
 =item restore
 
 Restores the enviroment and descriptors. Can only be called after setup.