X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FHTTP%2FRequest%2FAsCGI.pm;h=decddd63e87b2a02307ad3eefb912921d4fca1b2;hb=71dd2bc0b1bde492f5e81d24b40cdbf9360df01a;hp=31279fe86bb0ce209e0e7668c2f9efe12453f914;hpb=2aaf55bcc25c7c95a5e5783d17c22157c600b178;p=catagits%2FHTTP-Request-AsCGI.git diff --git a/lib/HTTP/Request/AsCGI.pm b/lib/HTTP/Request/AsCGI.pm index 31279fe..decddd6 100644 --- a/lib/HTTP/Request/AsCGI.pm +++ b/lib/HTTP/Request/AsCGI.pm @@ -1,137 +1,297 @@ package HTTP::Request::AsCGI; - +# ABSTRACT: Set up a CGI environment from an HTTP::Request use strict; use warnings; +use bytes; use base 'Class::Accessor::Fast'; use Carp; +use HTTP::Response; +use IO::Handle; use IO::File; +use URI (); +use URI::Escape (); + +__PACKAGE__->mk_accessors(qw[ environment request stdin stdout stderr ]); + +# old typo + +=begin Pod::Coverage + + enviroment + +=end Pod::Coverage + +=cut -__PACKAGE__->mk_accessors( qw[ enviroment request stdin stdout stderr ] ); +*enviroment = \&environment; -our $VERSION = 0.1; +my %reserved = map { sprintf('%02x', ord($_)) => 1 } split //, $URI::reserved; +sub _uri_safe_unescape { + my ($s) = @_; + $s =~ s/%([a-fA-F0-9]{2})/$reserved{lc($1)} ? "%$1" : pack('C', hex($1))/ge; + $s +} sub new { my $class = shift; my $request = shift; - my $self = { - request => $request, - restored => 0, - setuped => 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 ); + + 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 ); + + # Get it before canonicalized so REQUEST_URI can be as raw as possible + my $request_uri = $uri->path_query; - $self->{enviroment} = { + $uri = $uri->canonical; + + my $environment = { 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/' . our $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 => $request_uri, # not in RFC 3875 REQUEST_METHOD => $request->method, @_ }; + # RFC 3875 says PATH_INFO is not URI-encoded. That's really + # annoying for applications that you can't tell "%2F" vs "/", but + # doing the partial decoding then makes it impossible to tell + # "%252F" vs "%2F". Encoding everything is more compatible to what + # web servers like Apache or lighttpd do, anyways. + $environment->{PATH_INFO} = URI::Escape::uri_unescape($environment->{PATH_INFO}); + foreach my $field ( $request->headers->header_field_names ) { - my $key = uc($field); + my $key = uc("HTTP_$field"); $key =~ tr/-/_/; - $key = 'HTTP_' . $key unless $field =~ /^Content-(Length|Type)$/; + $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/; - unless ( exists $self->{enviroment}->{$key} ) { - $self->{enviroment}->{$key} = $request->headers->header($field); + unless ( exists $environment->{$key} ) { + $environment->{$key} = $request->headers->header($field); } } - return $class->SUPER::new($self); + unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) { + $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//; + $environment->{PATH_INFO} =~ s/^\/+/\//; + } + + $self->environment($environment); + + return $self; } sub setup { my $self = shift; - open( my $stdin, '>&', STDIN->fileno ) + $self->{restore}->{environment} = {%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: $!"); + + open( STDOUT, '>&='. $self->stdout->fileno ) + or croak("Can't open stdout: $!"); + + binmode( $self->stdout ); + binmode( STDOUT); + } + + if ( $self->stderr ) { - $self->stdin->syswrite( $self->request->content ) - or croak("Can't write content to stdin: $!"); + open( $self->{restore}->{stderr}, '>&'. STDERR->fileno ) + or croak("Can't dup stderr: $!"); - $self->stdin->sysseek( 0, SEEK_SET ) - or croak("Can't seek stdin: $!"); + open( STDERR, '>&='. $self->stderr->fileno ) + or croak("Can't open stderr: $!"); + + binmode( $self->stderr ); + binmode( STDERR ); } { no warnings 'uninitialized'; - %ENV = %{ $self->enviroment }; + %ENV = (%ENV, %{ $self->environment }); } - open( STDIN, '<&=', $self->stdin->fileno ) - or croak("Can't open stdin: $!"); - - open( STDOUT, '>&=', $self->stdout->fileno ) - or croak("Can't open stdout: $!"); + 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 = defined $response->content ? length( $response->content ) : 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}->{environment} }; + } - 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} ) { - if ( $self->stdin->fileno != STDIN->fileno ) { - $self->stdin->sysseek( 0, SEEK_SET ) - or croak("Can't seek stdin: $!"); - } + STDOUT->flush + or croak("Can't flush stdout: $!"); - if ( $self->stdout->fileno != STDOUT->fileno ) { - $self->stdout->sysseek( 0, SEEK_SET ) + 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->stderr->fileno != STDERR->fileno ) { - $self->stderr->sysseek( 0, SEEK_SET ) + if ( $self->{restore}->{stderr} ) { + + STDERR->flush + or croak("Can't flush 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 { @@ -143,70 +303,99 @@ sub DESTROY { __END__ -=head1 NAME - -HTTP::Request::AsCGI - Setup a CGI enviroment from a HTTP::Request - =head1 SYNOPSIS use CGI; use HTTP::Request; use HTTP::Request::AsCGI; - + my $request = HTTP::Request->new( GET => 'http://www.host.com/' ); my $stdout; - + { my $c = HTTP::Request::AsCGI->new($request)->setup; my $q = CGI->new; - + print $q->header, $q->start_html('Hello World'), $q->h1('Hello World'), $q->end_html; - + $stdout = $c->stdout; - - # enviroment and descriptors will automatically be restored when $c is destructed. + + # environment and descriptors will automatically be restored + # when $c is destructed. } - + while ( my $line = $stdout->getline ) { print $line; } - + =head1 DESCRIPTION +Provides a convenient way of setting up an CGI environment from an HTTP::Request. + =head1 METHODS -=over 4 +=over 4 + +=item new ( $request [, key => value ] ) -=item new +Constructor. The first argument must be a instance of HTTP::Request, followed +by optional pairs of environment key and value. -=item enviroment +=item environment + +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 +Sets up the environment and descriptors. + =item restore +Restores the environment 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 -=head1 AUTHOR +=item examples directory in this distribution. -Christian Hansen, C +=item L + +=item L + +=back -=head1 LICENSE +=head1 THANKS TO -This library is free software. You can redistribute it and/or modify -it under the same terms as perl itself. +Thomas L. Shinnick for his valuable win32 testing. =cut