From: Christian Hansen Date: Sun, 16 Oct 2005 23:14:47 +0000 (+0000) Subject: added binmode and minor refactoring X-Git-Tag: v1.0~50 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FHTTP-Request-AsCGI.git;a=commitdiff_plain;h=090cc06098fe44e972670fa00b2c57ad80b71359 added binmode and minor refactoring --- diff --git a/examples/daemon.pl b/examples/daemon.pl index 6a6d8e7..9a040e3 100644 --- a/examples/daemon.pl +++ b/examples/daemon.pl @@ -42,7 +42,7 @@ while ( my $client = $server->accept ) { my $response = $c->response; - # set close to prevent blocking problems in single threaded daemon + # to prevent blocking problems in single threaded daemon. $response->header( Connection => 'close' ); $client->send_response($response); diff --git a/lib/HTTP/Request/AsCGI.pm b/lib/HTTP/Request/AsCGI.pm index 70cf9c8..7f92588 100644 --- a/lib/HTTP/Request/AsCGI.pm +++ b/lib/HTTP/Request/AsCGI.pm @@ -2,12 +2,13 @@ package HTTP::Request::AsCGI; use strict; use warnings; +use bytes; use base 'Class::Accessor::Fast'; use Carp; use IO::File; -__PACKAGE__->mk_accessors( qw[ enviroment request stdin stdout stderr ] ); +__PACKAGE__->mk_accessors(qw[ enviroment request stdin stdout stderr ]); our $VERSION = 0.1; @@ -27,6 +28,7 @@ sub new { $self->{enviroment} = { GATEWAY_INTERFACE => 'CGI/1.1', HTTP_HOST => $request->uri->host_port, + PATH_INFO => $request->uri->path, QUERY_STRING => $request->uri->query || '', SCRIPT_NAME => '/', SERVER_NAME => $request->uri->host, @@ -58,21 +60,15 @@ sub new { sub setup { my $self = shift; - open( my $stdin, '>&', STDIN->fileno ) - or croak("Can't dup stdin: $!"); - - open( my $stdout, '>&', STDOUT->fileno ) - or croak("Can't dup stdout: $!"); + $self->{restore}->{enviroment} = {%ENV}; - open( my $stderr, '>&', STDERR->fileno ) - or croak("Can't dup stderr: $!"); + open( $self->{restore}->{stdin}, '>&', STDIN->fileno ) + or croak("Can't dup stdin: $!"); - $self->{restore} = { - stdin => $stdin, - stdout => $stdout, - stderr => $stderr, - enviroment => {%ENV} - }; + open( STDIN, '<&=', $self->stdin->fileno ) + or croak("Can't open stdin: $!"); + + binmode( STDIN, ':raw' ); if ( $self->request->content_length ) { @@ -83,20 +79,31 @@ sub setup { or croak("Can't seek stdin handle: $!"); } + if ( $self->stdout ) { + open( $self->{restore}->{stdout}, '>&', STDOUT->fileno ) + or croak("Can't dup stdout: $!"); + + open( STDOUT, '>&=', $self->stdout->fileno ) + or croak("Can't open stdout: $!"); + + binmode( STDOUT, ':raw' ); + } + + if ( $self->stderr ) { + open( $self->{restore}->{stderr}, '>&', STDERR->fileno ) + or croak("Can't dup stderr: $!"); + + open( STDERR, '>&=', $self->stderr->fileno ) + or croak("Can't open stderr: $!"); + + binmode( STDERR, ':raw' ); + } + { no warnings 'uninitialized'; %ENV = %{ $self->enviroment }; } - open( STDIN, '<&=', $self->stdin->fileno ) - or croak("Can't open stdin: $!"); - - open( STDOUT, '>&=', $self->stdout->fileno ) - or croak("Can't open stdout: $!"); - - open( STDERR, '>&=', $self->stderr->fileno ) - or croak("Can't open stderr: $!"); - $self->{setuped}++; return $self; @@ -107,13 +114,14 @@ sub response { return undef unless $self->{setuped}; return undef unless $self->{restored}; + return undef unless $self->{restore}->{stdout}; require HTTP::Response; my $message = undef; my $position = $self->stdin->tell; - $self->stdin->sysseek( 0, SEEK_SET ) + $self->stdout->sysseek( 0, SEEK_SET ) or croak("Can't seek stdin handle: $!"); while ( my $line = $self->stdout->getline ) { @@ -134,13 +142,13 @@ sub response { $response->protocol( $self->request->protocol ); $response->headers->date( time() ); - if ( $callback ) { + if ($callback) { $response->content( sub { if ( $self->stdout->read( my $buffer, 4096 ) ) { return $buffer; } return undef; - }); + }); } else { my $length = 0; @@ -151,7 +159,7 @@ sub response { $response->content_length($length) unless $response->content_length; } - $self->stdin->sysseek( $position, SEEK_SET ) + $self->stdout->sysseek( $position, SEEK_SET ) or croak("Can't seek stdin handle: $!"); return $response; @@ -165,26 +173,28 @@ sub restore { open( STDIN, '>&', $self->{restore}->{stdin} ) or croak("Can't restore stdin: $!"); - open( STDOUT, '>&', $self->{restore}->{stdout} ) - or croak("Can't restore stdout: $!"); - - open( STDERR, '>&', $self->{restore}->{stderr} ) - or croak("Can't restore stderr: $!"); - $self->stdin->sysseek( 0, SEEK_SET ) or croak("Can't seek stdin: $!"); - if ( $self->stdout->fileno != STDOUT->fileno ) { + if ( $self->{restore}->{stdout} ) { + open( STDOUT, '>&', $self->{restore}->{stdout} ) + or croak("Can't restore stdout: $!"); + $self->stdout->sysseek( 0, SEEK_SET ) or croak("Can't seek stdout: $!"); } - if ( $self->stderr->fileno != STDERR->fileno ) { + if ( $self->{restore}->{stderr} ) { + open( STDERR, '>&', $self->{restore}->{stderr} ) + or croak("Can't restore stderr: $!"); + $self->stderr->sysseek( 0, SEEK_SET ) or croak("Can't seek stderr: $!"); } $self->{restored}++; + + return $self; } sub DESTROY { diff --git a/t/05env.t b/t/05env.t index 51cd0b8..c5c5351 100644 --- a/t/05env.t +++ b/t/05env.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 8; +use Test::More tests => 9; use strict; use warnings; @@ -9,15 +9,16 @@ use IO::File; use HTTP::Request; use HTTP::Request::AsCGI; -my $r = HTTP::Request->new( GET => 'http://www.host.com/cgi-bin/script.cgi?a=1&b=2' ); +my $r = HTTP::Request->new( GET => 'http://www.host.com/my/path/?a=1&b=2' ); my $c = HTTP::Request::AsCGI->new($r); -$c->stdout( IO::File->new_from_fd( STDOUT->fileno, '>' ) ); -$c->stderr( IO::File->new_from_fd( STDERR->fileno, '>' ) ); +$c->stdout(undef); +$c->stderr(undef); $c->setup; is( $ENV{GATEWAY_INTERFACE}, 'CGI/1.1', 'GATEWAY_INTERFACE' ); is( $ENV{HTTP_HOST}, 'www.host.com:80', 'HTTP_HOST' ); +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{REQUEST_METHOD}, 'GET', 'REQUEST_METHOD' );