improved examples and tests

diff --git a/examples/daemon.pl b/examples/daemon.pl
index a946d07..c718487 100644 (file)
--- 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:", $server->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 (file)
--- 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 (file)
--- 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 (file)
--- 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' );