From: Christian Hansen Date: Mon, 17 Oct 2005 17:00:21 +0000 (+0000) Subject: improved examples and tests X-Git-Tag: v1.0~46 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FHTTP-Request-AsCGI.git;a=commitdiff_plain;h=30efa07df1adab28ba911f7cac845256decc3933 improved examples and tests --- diff --git a/examples/daemon.pl b/examples/daemon.pl index a946d07..c718487 100644 --- a/examples/daemon.pl +++ b/examples/daemon.pl @@ -8,10 +8,12 @@ use HTTP::Daemon; use HTTP::Request; use HTTP::Request::AsCGI; use HTTP::Response; +use URI; $SIG{'PIPE'} = 'IGNORE'; -my $server = HTTP::Daemon->new( LocalPort => 3000, ReuseAddr => 1 ) || die; +my $server = HTTP::Daemon->new( LocalPort => 3000, ReuseAddr => 1 ) + or die( "Can't create daemon: $!" ); print "Please contact me at: url, ">\n"; @@ -25,10 +27,9 @@ while ( my $client = $server->accept ) { while ( my $request = $client->get_request ) { - CGI::initialize_globals(); - - $request->uri->scheme('http'); - $request->uri->host_port( $request->header('Host') || URI->new($server)->host_port ); + unless ( $request->uri->host ) { + $request->uri( URI->new_abs( $request->uri, $server->url ) ); + } my $c = HTTP::Request::AsCGI->new( $request, %e )->setup; my $q = CGI->new; @@ -50,8 +51,14 @@ while ( my $client = $server->accept ) { ), $q->submit, $q->end_form, - $q->h2('Params'), + $q->h2('Parameters'), $q->Dump, + $q->h2('Enviroment'), + $q->table( + $q->Tr( [ + map{ $q->td( [ $_, $ENV{$_} ] ) } sort keys %ENV + ] ) + ), $q->end_html; my $response = $c->restore->response; diff --git a/examples/mechanize.pl b/examples/mechanize.pl index 2e19291..2026cf7 100644 --- a/examples/mechanize.pl +++ b/examples/mechanize.pl @@ -6,9 +6,9 @@ use strict; use warnings; use base 'Test::WWW::Mechanize'; -use CGI; use HTTP::Request; use HTTP::Request::AsCGI; +use HTTP::Response; sub cgi { my $self = shift; @@ -26,8 +26,19 @@ sub _make_request { $self->cookie_jar->add_cookie_header($request) if $self->cookie_jar; my $c = HTTP::Request::AsCGI->new($request)->setup; - $self->cgi->(); - my $response = $c->restore->response; + + eval { $self->cgi->() }; + + my $response; + + if ( $@ ) { + $response = HTTP::Response->new(500); + $response->date( time() ); + $response->content( $response->error_as_HTML ); + } + else { + $response = $c->restore->response; + } $response->header( 'Content-Base', $request->uri ); $response->request($request); @@ -40,19 +51,18 @@ package main; use strict; use warnings; +use CGI; use Test::More tests => 3; my $mech = Test::WWW::Mechanize::CGI->new; $mech->cgi( sub { - CGI::initialize_globals(); - my $q = CGI->new; - print $q->header, - $q->start_html('Hello World'), + print $q->header, + $q->start_html('Hello World'), $q->h1('Hello World'), - $q->end_html; + $q->end_html; }); $mech->get_ok('http://localhost/'); diff --git a/lib/HTTP/Request/AsCGI.pm b/lib/HTTP/Request/AsCGI.pm index be0bece..43207e6 100644 --- a/lib/HTTP/Request/AsCGI.pm +++ b/lib/HTTP/Request/AsCGI.pm @@ -6,6 +6,7 @@ use bytes; use base 'Class::Accessor::Fast'; use Carp; +use IO::Handle; use IO::File; __PACKAGE__->mk_accessors(qw[ enviroment request stdin stdout stderr ]); @@ -24,20 +25,28 @@ sub new { 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 ); + $self->{enviroment} = { GATEWAY_INTERFACE => 'CGI/1.1', - HTTP_HOST => $request->uri->host_port, - PATH_INFO => $request->uri->path, - QUERY_STRING => $request->uri->query || '', + 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 => $request->uri->host, - SERVER_PORT => $request->uri->port, + 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, @_ }; @@ -72,14 +81,15 @@ sub setup { if ( $self->request->content_length ) { - $self->stdin->syswrite( $self->request->content ) + syswrite( $self->stdin, $self->request->content ) or croak("Can't write request content to stdin handle: $!"); - $self->stdin->sysseek( 0, SEEK_SET ) + sysseek( $self->stdin, 0, SEEK_SET ) or croak("Can't seek stdin handle: $!"); } if ( $self->stdout ) { + open( $self->{restore}->{stdout}, '>&', STDOUT->fileno ) or croak("Can't dup stdout: $!"); @@ -91,6 +101,7 @@ sub setup { } if ( $self->stderr ) { + open( $self->{restore}->{stderr}, '>&', STDERR->fileno ) or croak("Can't dup stderr: $!"); @@ -105,6 +116,10 @@ sub setup { no warnings 'uninitialized'; %ENV = %{ $self->enviroment }; } + + if ( $INC{'CGI.pm'} ) { + CGI::initialize_globals(); + } $self->{setuped}++; @@ -120,13 +135,13 @@ sub response { require HTTP::Response; - my $message = undef; - my $position = $self->stdin->tell; + my $message = undef; + my $stdout = $self->stdout; - $self->stdout->sysseek( 0, SEEK_SET ) - or croak("Can't seek stdin handle: $!"); + seek( $self->stdout, 0, SEEK_SET ) + or croak("Can't seek stdout handle: $!"); - while ( my $line = $self->stdout->getline ) { + while ( my $line = <$stdout> ) { $message .= $line; last if $line =~ /^\x0d?\x0a$/; } @@ -161,9 +176,6 @@ sub response { $response->content_length($length) unless $response->content_length; } - $self->stdout->sysseek( $position, SEEK_SET ) - or croak("Can't seek stdin handle: $!"); - return $response; } @@ -175,22 +187,30 @@ sub restore { open( STDIN, '>&', $self->{restore}->{stdin} ) or croak("Can't restore stdin: $!"); - $self->stdin->sysseek( 0, SEEK_SET ) + sysseek( $self->stdin, 0, SEEK_SET ) or croak("Can't seek stdin: $!"); if ( $self->{restore}->{stdout} ) { + + STDOUT->flush + or croak("Can't flush stdout: $!"); + open( STDOUT, '>&', $self->{restore}->{stdout} ) or croak("Can't restore stdout: $!"); - $self->stdout->sysseek( 0, SEEK_SET ) + sysseek( $self->stdout, 0, SEEK_SET ) or croak("Can't seek stdout: $!"); } if ( $self->{restore}->{stderr} ) { + + STDERR->flush + or croak("Can't flush stderr: $!"); + open( STDERR, '>&', $self->{restore}->{stderr} ) or croak("Can't restore stderr: $!"); - $self->stderr->sysseek( 0, SEEK_SET ) + sysseek( $self->stderr, 0, SEEK_SET ) or croak("Can't seek stderr: $!"); } diff --git a/t/05env.t b/t/05env.t index c21c5cb..782a123 100644 --- a/t/05env.t +++ b/t/05env.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 9; +use Test::More tests => 10; use strict; use warnings; @@ -9,7 +9,7 @@ use IO::File; use HTTP::Request; use HTTP::Request::AsCGI; -my $r = HTTP::Request->new( GET => 'http://www.host.com/my/path/?a=1&b=2' ); +my $r = HTTP::Request->new( GET => 'http://www.host.com/my/path/?a=1&b=2', [ 'X-Test' => 'Test' ] ); my $c = HTTP::Request::AsCGI->new($r); $c->stdout(undef); @@ -17,6 +17,7 @@ $c->setup; is( $ENV{GATEWAY_INTERFACE}, 'CGI/1.1', 'GATEWAY_INTERFACE' ); is( $ENV{HTTP_HOST}, 'www.host.com:80', 'HTTP_HOST' ); +is( $ENV{HTTP_X_TEST}, 'Test', 'HTTP_X_TEST' ); is( $ENV{PATH_INFO}, '/my/path/', 'PATH_INFO' ); is( $ENV{QUERY_STRING}, 'a=1&b=2', 'QUERY_STRING' ); is( $ENV{SCRIPT_NAME}, '/', 'SCRIPT_NAME' );