[Rt-commit] r2539 - in HTTP-Server-Simple: . lib/HTTP/Server t
jesse at bestpractical.com
jesse at bestpractical.com
Wed Mar 30 11:03:20 EST 2005
Author: jesse
Date: Wed Mar 30 11:03:20 2005
New Revision: 2539
Added:
HTTP-Server-Simple/t/04cgi.t
Modified:
HTTP-Server-Simple/ (props changed)
HTTP-Server-Simple/Changes
HTTP-Server-Simple/MANIFEST
HTTP-Server-Simple/lib/HTTP/Server/Simple.pm
Log:
r10304 at hualien: jesse | 2005-03-29 10:39:49 +0800
New tests from hide
Modified: HTTP-Server-Simple/Changes
==============================================================================
--- HTTP-Server-Simple/Changes (original)
+++ HTTP-Server-Simple/Changes Wed Mar 30 11:03:20 2005
@@ -1,3 +1,7 @@
+0.08
+
+- New tests for HTTP::Server:Simple::CGI from hide.
+
0.07 Sat Mar 26 14:25:38 CST 2005
- PAUSE broke :/
Modified: HTTP-Server-Simple/MANIFEST
==============================================================================
--- HTTP-Server-Simple/MANIFEST (original)
+++ HTTP-Server-Simple/MANIFEST Wed Mar 30 11:03:20 2005
@@ -19,3 +19,4 @@
t/01live.t
t/02pod.t
t/03podcoverage.t
+t/04cgi.t
Modified: HTTP-Server-Simple/lib/HTTP/Server/Simple.pm
==============================================================================
--- HTTP-Server-Simple/lib/HTTP/Server/Simple.pm (original)
+++ HTTP-Server-Simple/lib/HTTP/Server/Simple.pm Wed Mar 30 11:03:20 2005
@@ -5,7 +5,7 @@
use Socket;
use Carp;
-our $VERSION = '0.07';
+our $VERSION = '0.08';
=head1 NAME
Added: HTTP-Server-Simple/t/04cgi.t
==============================================================================
--- (empty file)
+++ HTTP-Server-Simple/t/04cgi.t Wed Mar 30 11:03:20 2005
@@ -0,0 +1,162 @@
+use Test::More tests => 22;
+use Socket;
+use strict;
+
+use constant PORT => 13432;
+
+our %methods=(
+ url => 'url: http://localhost(?:\.localdomain)?:'.PORT,
+ path_info => 'path_info: /cgitest/path_info',
+ remote_host => 'remote_host: localhost',
+ server_name => 'server_name: localhost',
+ server_port => 'server_port: '.PORT,
+ server_software => 'server_software: HTTP::Server::Simple/\d+.\d+',
+ request_method => 'request_method: GET',
+ );
+
+our %envvars=(
+ SERVER_URL => 'SERVER_URL: http://localhost(?:\.localdomain)?:'.PORT.'/',
+ SERVER_PORT => 'SERVER_PORT: '.PORT,
+ REQUEST_METHOD => 'REQUEST_METHOD: GET',
+ REQUEST_URI => 'REQUEST_URI: /cgitest/REQUEST_URI',
+ SERVER_PROTOCOL => 'SERVER_PROTOCOL: HTTP/1.1',
+ SERVER_NAME => 'SERVER_NAME: localhost',
+ SERVER_SOFTWARE => 'SERVER_SOFTWARE: HTTP::Server::Simple/\d+.\d+',
+ REMOTE_HOST => 'REMOTE_HOST: localhost',
+ REMOTE_ADDR => 'REMOTE_ADDR: 127.0.0.1',
+ QUERY_STRING => 'QUERY_STRING: ',
+ PATH_INFO => 'PATH_INFO: /cgitest/PATH_INFO',
+ );
+
+{
+ my $server=CGIServer->new(PORT);
+ is($server->port(),PORT,'Constructor set port correctly');
+ select(undef,undef,undef,0.2); # wait a sec
+
+ my $pid=$server->background;
+
+ like($pid,qr/^-?\d+$/,'pid is numeric');
+
+ select(undef,undef,undef,0.2); # wait a sec
+ like(fetch("GET / HTTP/1.1",""),qr(NOFILE),'no file');
+
+ foreach my $method (keys(%methods)) {
+ like(
+ fetch("GET /cgitest/$method HTTP/1.1",""),
+ qr($methods{$method}),
+ "method - $method"
+ );
+ select(undef,undef,undef,0.2); # wait a sec
+ }
+
+ foreach my $envvar (keys(%envvars)) {
+ like(
+ fetch("GET /cgitest/$envvar HTTP/1.1",""),
+ qr($envvars{$envvar}),
+ "Environment - $envvar"
+ );
+ select(undef,undef,undef,0.2); # wait a sec
+ }
+
+ is(kill(9,$pid),1,'Signaled 1 process successfully');
+ wait or die "counldn't wait for sub-process completion";
+}
+
+
+sub fetch {
+
+ my @response;
+ my $alarm = 0;
+ my $stage = "init";
+
+ my %messages =
+ ( "init" => "inner contemplation",
+ "lookup" => ("lookup of `localhost' - may be caused by a "
+ ."missing hosts entry or broken resolver"),
+ "sockaddr" => "call to sockaddr_in() - ?",
+ "proto" => ("call to getprotobyname() - may be caused by "
+ ."bizarre NSS configurations"),
+ "socket" => "socket creation",
+ "connect" => ("connect() - may be caused by a missing or "
+ ."broken loopback interface, or firewalling"),
+ "send" => "network send()",
+ "recv" => "collection of response",
+ "close" => "closing socket"
+ );
+
+ $SIG{ALRM} = sub {
+ @response = "timed out during $messages{$stage}";
+ $alarm = 1;
+ };
+
+ my ($iaddr, $paddr, $proto, $message);
+
+ $message = join "", map { "$_\015\012" } @_;
+
+ my %states =
+ ( 'init' => sub { "lookup"; },
+ "lookup" => sub { ($iaddr = inet_aton("localhost"))
+ && "sockaddr" },
+ "sockaddr" => sub { ($paddr = sockaddr_in(PORT, $iaddr))
+ && "proto" },
+ "proto" => sub { ($proto = getprotobyname('tcp'))
+ && "socket" },
+ "socket" => sub { socket(SOCK, PF_INET, SOCK_STREAM, $proto)
+ && "connect" },
+ "connect" => sub { connect(SOCK, $paddr) && "send" },
+ "send" => sub { (send SOCK, $message, 0) && "recv" },
+ "recv" => sub {
+ my $line;
+ while (!$alarm and defined($line = <SOCK>)) {
+ push @response, $line;
+ }
+ ($alarm ? undef : "close");
+ },
+ "close" => sub { close SOCK; "done"; },
+ );
+
+ # this entire cycle should finish way before this timer expires
+ alarm(5);
+
+ my $next;
+ $stage = $next
+ while (!$alarm && $stage ne "done"
+ && ($next = $states{$stage}->()));
+
+ warn "early exit from `$stage' stage; $!" unless $next;
+
+ # bank on the test testing for something in the response.
+ return join "", @response;
+
+
+}
+
+{
+ package CGIServer;
+ use base qw(HTTP::Server::Simple::CGI);
+ use Env;
+ use Data::Dumper;
+
+
+ sub handle_request {
+ my $self=shift;
+ my $cgi=shift;
+
+
+ my $file=(split('/',$cgi->path_info))[-1]||'NOFILE';
+ $file=~s/\s+//g;
+ $file||='NOFILE';
+ print "HTTP/1.0 200 OK\r\n"; # probably OK by now
+ print "Content-Type: text/html\r\nContent-Length: ";
+ my $response;
+ if($methods{$file}) {
+ $response="$file: ".$cgi->$file;
+ } elsif($envvars{$file}) {
+ $response="$file: $ENV{$file}";
+ } else {
+ $response=$file;
+ }
+ print length($response), "\r\n\r\n", $response;
+ }
+}
+
More information about the Rt-commit
mailing list