X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FHTTP%2FRequest%2FAsCGI.pm;h=77d035f5fe08acf4690859bc868a51cb6d7d20ae;hb=b2c02cd0631cd096ae9d40f5c58fa27b38dd3013;hp=1b0526ca5b8b87eb86061124bf1305c75aa061a0;hpb=128529591fd44541f66ab7d92ae78845ffe584a1;p=catagits%2FHTTP-Request-AsCGI.git diff --git a/lib/HTTP/Request/AsCGI.pm b/lib/HTTP/Request/AsCGI.pm index 1b0526c..77d035f 100644 --- a/lib/HTTP/Request/AsCGI.pm +++ b/lib/HTTP/Request/AsCGI.pm @@ -2,129 +2,272 @@ package HTTP::Request::AsCGI; use strict; use warnings; +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 ] ); +__PACKAGE__->mk_accessors(qw[ enviroment request stdin stdout stderr ]); -our $VERSION = 0.1; +our $VERSION = 0.5_03; sub new { my $class = shift; my $request = shift; - my $self = { - request => $request, - restored => 0, - stdin => IO::File->new_tmpfile, - stdout => IO::File->new_tmpfile, - stderr => IO::File->new_tmpfile - }; + 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 ); - $self->{enviroment} = { + 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 = $uri->canonical; + + my $enviroment = { GATEWAY_INTERFACE => 'CGI/1.1', - HTTP_HOST => $request->uri->host_port, - QUERY_STRING => $request->uri->query || '', - SCRIPT_NAME => $request->uri->path || '/', - SERVER_NAME => $request->uri->host, - SERVER_PORT => $request->uri->port, + 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 => __PACKAGE__ . "/" . $VERSION, + 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 => $request->uri->path || '/', # not in RFC 3875 + REMOTE_PORT => int( rand(64000) + 1000 ), # 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); - $key =~ tr/_/-/; - $key = 'HTTP_' . $key unless $field =~ /^Content-(Length|Type)$/; + my $key = uc("HTTP_$field"); + $key =~ tr/-/_/; + $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 { my $self = shift; - open( my $stdin, '>&', STDIN->fileno ) + $self->{restore}->{enviroment} = {%ENV}; + + binmode( $self->stdin ); + + if ( $self->request->content_length ) { + + $self->stdin->print($self->request->content) + or croak("Can't write request content to stdin handle: $!"); + + $self->stdin->seek(0, SEEK_SET) + or croak("Can't seek stdin handle: $!"); + + $self->stdin->flush + or croak("Can't flush stdin handle: $!"); + } + + open( $self->{restore}->{stdin}, '<&'. STDIN->fileno ) or croak("Can't dup stdin: $!"); - open( my $stdout, '>&', STDOUT->fileno ) - or croak("Can't dup stdout: $!"); + open( STDIN, '<&='. $self->stdin->fileno ) + or croak("Can't open stdin: $!"); - open( my $stderr, '>&', STDERR->fileno ) - or croak("Can't dup stderr: $!"); + binmode( STDIN ); - $self->{restore} = { - stdin => $stdin, - stdout => $stdout, - stderr => $stderr, - enviroment => {%ENV} - }; + if ( $self->stdout ) { - if ( $self->request->content_length ) { + open( $self->{restore}->{stdout}, '>&'. STDOUT->fileno ) + or croak("Can't dup stdout: $!"); - $self->stdin->syswrite( $self->request->content ) - or croak("Can't write content to stdin: $!"); + open( STDOUT, '>&='. $self->stdout->fileno ) + or croak("Can't open stdout: $!"); - $self->stdin->sysseek( 0, SEEK_SET ) - or croak("Can't seek stdin: $!"); + binmode( $self->stdout ); + binmode( STDOUT); } - %ENV = %{ $self->enviroment }; + if ( $self->stderr ) { - open( STDIN, '<&=', $self->stdin->fileno ) - or croak("Can't open stdin: $!"); + open( $self->{restore}->{stderr}, '>&'. STDERR->fileno ) + or croak("Can't dup stderr: $!"); + + open( STDERR, '>&='. $self->stderr->fileno ) + or croak("Can't open stderr: $!"); + + binmode( $self->stderr ); + binmode( STDERR ); + } - open( STDOUT, '>&=', $self->stdout->fileno ) - or croak("Can't open stdout: $!"); + { + no warnings 'uninitialized'; + %ENV = %{ $self->enviroment }; + } + + if ( $INC{'CGI.pm'} ) { + CGI::initialize_globals(); + } - open( STDERR, '>&=', $self->stderr->fileno ) - or croak("Can't open stderr: $!"); + $self->{setuped}++; return $self; } +sub response { + my ( $self, $callback ) = @_; + + return undef unless $self->stdout; + + seek( $self->stdout, 0, SEEK_SET ) + or croak("Can't seek stdout handle: $!"); + + my $headers; + while ( my $line = $self->stdout->getline ) { + $headers .= $line; + last if $headers =~ /\x0d?\x0a\x0d?\x0a$/; + } + + unless ( defined $headers ) { + $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a"; + } + + unless ( $headers =~ /^HTTP/ ) { + $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers; + } + + my $response = HTTP::Response->parse($headers); + $response->date( time() ) unless $response->date; + + my $message = $response->message; + my $status = $response->header('Status'); + + if ( $message && $message =~ /^(.+)\x0d$/ ) { + $response->message($1); + } + + if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) { + + my $code = $1; + my $message = $2 || HTTP::Status::status_message($code); + + $response->code($code); + $response->message($message); + } + + my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout ); + + if ( $response->code == 500 && !$length ) { + + $response->content( $response->error_as_HTML ); + $response->content_type('text/html'); + + return $response; + } + + if ($callback) { + + my $handle = $self->stdout; + + $response->content( sub { + + 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); + } + } + + return $response; +} + sub restore { my $self = shift; - %ENV = %{ $self->{restore}->{enviroment} }; + { + no warnings 'uninitialized'; + %ENV = %{ $self->{restore}->{enviroment} }; + } - open( STDIN, '>&', $self->{restore}->{stdin} ) + open( STDIN, '<&'. fileno($self->{restore}->{stdin}) ) or croak("Can't restore stdin: $!"); - open( STDOUT, '>&', $self->{restore}->{stdout} ) - or croak("Can't restore stdout: $!"); + sysseek( $self->stdin, 0, SEEK_SET ) + or croak("Can't seek stdin: $!"); - open( STDERR, '>&', $self->{restore}->{stderr} ) - or croak("Can't restore stderr: $!"); + if ( $self->{restore}->{stdout} ) { - $self->stdin->sysseek( 0, SEEK_SET ) - or croak("Can't seek stdin: $!"); + STDOUT->flush + or croak("Can't flush stdout: $!"); + + open( STDOUT, '>&'. fileno($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} ) { - $self->stdout->sysseek( 0, SEEK_SET ) - or croak("Can't seek stdout: $!"); + STDERR->flush + or croak("Can't flush stderr: $!"); - $self->stderr->sysseek( 0, SEEK_SET ) - or croak("Can't seek stderr: $!"); + open( STDERR, '>&'. fileno($self->{restore}->{stderr}) ) + or croak("Can't restore stderr: $!"); + + sysseek( $self->stderr, 0, SEEK_SET ) + or croak("Can't seek stderr: $!"); + } $self->{restored}++; + + return $self; } sub DESTROY { my $self = shift; - $self->restore unless $self->{restored}; + $self->restore if $self->{setuped} && !$self->{restored}; } 1; @@ -155,7 +298,8 @@ HTTP::Request::AsCGI - Setup a CGI enviroment from a HTTP::Request $stdout = $c->stdout; - # enviroment and descriptors will automatically be restored when $c is destructed. + # enviroment and descriptors will automatically be restored + # when $c is destructed. } while ( my $line = $stdout->getline ) { @@ -164,29 +308,70 @@ HTTP::Request::AsCGI - Setup a CGI enviroment from a HTTP::Request =head1 DESCRIPTION +Provides a convinient way of setting up an CGI enviroment from a HTTP::Request. + =head1 METHODS =over 4 -=item new +=item new ( $request [, key => value ] ) + +Contructor, first argument must be a instance of HTTP::Request +followed by optional pairs of environment key and value. =item enviroment +Returns a hashref containing the environment that will be used in setup. +Changing the hashref after setup has been called will have no effect. + =item setup +Setups the environment and descriptors. + =item restore +Restores the enviroment and descriptors. Can only be called after setup. + =item request +Returns the request given to constructor. + +=item response + +Returns a HTTP::Response. Can only be called after restore. + =item stdin +Accessor for handle that will be used for STDIN, must be a real seekable +handle with an file descriptor. Defaults to a tempoary IO::File instance. + =item stdout +Accessor for handle that will be used for STDOUT, must be a real seekable +handle with an file descriptor. Defaults to a tempoary IO::File instance. + =item stderr +Accessor for handle that will be used for STDERR, must be a real seekable +handle with an file descriptor. + =back -=head1 BUGS +=head1 SEE ALSO + +=over 4 + +=item examples directory in this distribution. + +=item L + +=item L + +=back + +=head1 THANKS TO + +Thomas L. Shinnick for his valuable win32 testing. =head1 AUTHOR