[Bps-public-commit] HTTP-Server-Simple branch, master, updated. 1d3333416e61d75c4088760b5576413126996e59
jesse
jesse at bestpractical.com
Wed Aug 12 20:13:57 EDT 2009
The branch, master has been updated
via 1d3333416e61d75c4088760b5576413126996e59 (commit)
from f5e58c220720044aa3dabfca5459d6e76864b0bf (commit)
Summary of changes:
Changes | 7 +--
SIGNATURE | 45 ------------------
lib/HTTP/Server/Simple.pm | 18 ++------
t/01live.t | 106 ++++++++++++++++---------------------------
t/04cgi.t | 111 +++++++++++++++++---------------------------
5 files changed, 90 insertions(+), 197 deletions(-)
delete mode 100644 SIGNATURE
mode change 100755 => 100644 lib/HTTP/Server/Simple.pm
- Log -----------------------------------------------------------------
commit 1d3333416e61d75c4088760b5576413126996e59
Author: Jesse Vincent <jesse at bestpractical.com>
Date: Wed Aug 12 17:15:55 2009 +0100
Applied updates from kmx working toward a working windows install
Subject: [rt.cpan.org #42546] t/04cgi.t fails test 20-21 on Windows
diff --git a/Changes b/Changes
index d8ba6f8..22bcde7 100644
--- a/Changes
+++ b/Changes
@@ -1,11 +1,10 @@
-0.38_03 Tue Jul 28 15:26:05 EDT 2009
+0.38_03 Sat Apr 11 18:47:29 EDT 2009
-* Patch from kmx at cpan.org to better randomize ports on Windows
-* Patch from kmx at cpan.org to try another fix for our 4cgi.t failures on windows
+* Subject: [rt.cpan.org #44961] [PATCH] xdg reports select() is problematic on win32
0.38_02 Fri Apr 10 20:57:19 EDT 2009
-* Specify an HTTP version for our GETs should get escaping to work
+* Specify an HTTP version for our GETs should get escaping to wokr
0.38_01 Mon Mar 2 18:11:46 EST 2009
* http://rt.cpan.org/Ticket/Attachment/568795/286902/ from confound++ for
diff --git a/SIGNATURE b/SIGNATURE
deleted file mode 100644
index ca3f3e6..0000000
--- a/SIGNATURE
+++ /dev/null
@@ -1,45 +0,0 @@
-This file contains message digests of all files listed in MANIFEST,
-signed via the Module::Signature module, version 0.55.
-
-To verify the content in this distribution, first make sure you have
-Module::Signature installed, then type:
-
- % cpansign -v
-
-It will check each file's integrity, as well as the signature's
-validity. If "==> Signature verified OK! <==" is not displayed,
-the distribution may already have been compromised, and you should
-not run its Makefile.PL or Build.PL.
-
------BEGIN PGP SIGNED MESSAGE-----
-Hash: SHA1
-
-SHA1 9f43485633064e5f49bb2658d663343e24b2167e Changes
-SHA1 0ac508c50476dcc2bf8fe3094cb341425291e1ee MANIFEST
-SHA1 cf3198cef8524b06b0f6df065b577225caf74a69 META.yml
-SHA1 1e68273869351212220429a4860ce710d5f3e291 Makefile.PL
-SHA1 ed0c107672daac3bc9e266876666e1059dbe44b7 README
-SHA1 4ea1e9072ca87399184a46233df52a21e285604d ex/sample_server
-SHA1 7e2cfa1b9efe0d502ee57717649c90ba4bd28ba9 inc/Module/Install.pm
-SHA1 6e1392d80a0f239eecd5664f7f21f922cedb9329 inc/Module/Install/Base.pm
-SHA1 f69417fe831d9cc22a78f00a617afadceade4d81 inc/Module/Install/Can.pm
-SHA1 c61d02895330310048bf388881b5e2e064031561 inc/Module/Install/Fetch.pm
-SHA1 54fcbed19232ec959bb17cfb4410599afc7f0779 inc/Module/Install/Makefile.pm
-SHA1 7d3be9b158e37b2b2c22084740099955623b1d56 inc/Module/Install/Metadata.pm
-SHA1 0a8b66180229ba2f9deaea1fedd0aacf7a7ace6b inc/Module/Install/Win32.pm
-SHA1 d3352eb33fe43a5f3ead513f645224fe34d73bc9 inc/Module/Install/WriteAll.pm
-SHA1 a124072dbbb35aa7c7e63d6cac747114365f80bc lib/HTTP/Server/Simple.pm
-SHA1 3ddd188b0ee926a7e114e711b88c0af69b9a9079 lib/HTTP/Server/Simple/CGI.pm
-SHA1 56e2d88c9a3ddd3b264d86279a52c099bbffa8f4 lib/HTTP/Server/Simple/CGI/Environment.pm
-SHA1 db064af54cab345a71daec576e32e64b8fb1033d t/00smoke.t
-SHA1 a88394bb5ff0fc9e3ba47418d8ec3b7719f5dc87 t/01live.t
-SHA1 aca95653cfce68912e08c57b3a4566207e2f99b3 t/02pod.t
-SHA1 a7024d0d8e7b80d26f75a3551a1406a797b382f8 t/03podcoverage.t
-SHA1 91a34cc0031af69dabc56091da31d45b94952c4b t/04cgi.t
------BEGIN PGP SIGNATURE-----
-Version: GnuPG v1.4.9 (Darwin)
-
-iEYEARECAAYFAknf8AUACgkQEi9d9xCOQEYNwACfWedImwW+OsrUSUmgJfB3vMBm
-NbIAoITbMmq/I6bMkJxWzURPW7KRdxoe
-=Tb6y
------END PGP SIGNATURE-----
diff --git a/lib/HTTP/Server/Simple.pm b/lib/HTTP/Server/Simple.pm
old mode 100755
new mode 100644
index 9b358cc..d3bd56d
--- a/lib/HTTP/Server/Simple.pm
+++ b/lib/HTTP/Server/Simple.pm
@@ -8,7 +8,7 @@ use Carp;
use URI::Escape;
use vars qw($VERSION $bad_request_doc);
-$VERSION = '0.38_03';
+$VERSION = '0.38_04';
=head1 NAME
@@ -206,26 +206,17 @@ started process. Any arguments will be passed through to L</run>.
sub background {
my $self = shift;
- require File::Temp;
- my ($fh, $filename) = File::Temp::tempfile();
- unlink($filename);
my $child = fork;
croak "Can't fork: $!" unless defined($child);
- if ($child) {
- while (eof($fh)) {
- select(undef, undef, undef, 0.1);
- seek($fh, 0, 0);
- }
- return $child;
- }
+ return $child if $child;
if ( $^O !~ /MSWin32/ ) {
require POSIX;
POSIX::setsid()
or croak "Can't start a new session: $!";
}
- $self->{after_setup} = sub { print {$fh} 1; close $fh };
- $self->run(@_);
+ $self->run(@_); # should never return
+ exit; # just to be sure
}
=head2 run [ARGUMENTS]
@@ -670,7 +661,6 @@ sub setup_listener {
)
or croak "bind to @{[$self->host||'*']}:@{[$self->port]}: $!";
listen( HTTPDaemon, SOMAXCONN ) or croak "listen: $!";
- $self->{after_setup} && $self->{after_setup}->();
}
diff --git a/t/01live.t b/t/01live.t
index 3c4789f..f4c5c0d 100644
--- a/t/01live.t
+++ b/t/01live.t
@@ -40,7 +40,7 @@ for my $class (@classes) {
my $s=HTTP::Server::Simple::CGI->new($PORT);
$s->host("localhost");
my $pid=$s->background();
- diag("started server PID=$pid");
+ diag("started server PID='$pid'");
like($pid, '/^-?\d+$/', 'pid is numeric');
select(undef,undef,undef,0.2); # wait a sec
my $content=fetch("GET / HTTP/1.1", "");
@@ -65,71 +65,45 @@ for my $class (@classes) {
# this function may look excessive, but hopefully will be very useful
# in identifying common problems
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;
-
-
+ my $hostname = "localhost";
+ my $port = $PORT;
+ my $message = join "", map { "$_\015\012" } @_;
+ my $timeout = 5;
+ my $response;
+
+ eval {
+ local $SIG{ALRM} = sub { die "early exit - SIGALRM caught" };
+ alarm $timeout*2; #twice longer than timeout used later by select()
+
+ my $iaddr = inet_aton($hostname) || die "inet_aton: $!";
+ my $paddr = sockaddr_in($port, $iaddr) || die "sockaddr_in: $!";
+ my $proto = getprotobyname('tcp') || die "getprotobyname: $!";
+ socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ connect(SOCK, $paddr) || die "connect: $!";
+ (send SOCK, $message, 0) || die "send: $!";
+
+ my $rvec = '';
+ vec($rvec, fileno(SOCK), 1) = 1;
+ die "vec(): $!" unless $rvec;
+
+ $response = '';
+ for (;;) {
+ my $r = select($rvec, undef, undef, $timeout);
+ die "select: timeout - no data to read from server" unless ($r > 0);
+ my $l = sysread(SOCK, $response, 1024, length($response));
+ die "sysread: $!" unless defined($l);
+ last if ($l == 0);
+ }
+ $response =~ s/\015\012/\n/g;
+ (close SOCK) || die "close(): $!";
+ alarm 0;
+ };
+ if ($@) {
+ return "[ERROR] $@";
+ }
+ else {
+ return $response;
+ }
}
sub run_server_tests {
diff --git a/t/04cgi.t b/t/04cgi.t
index 09f66c1..0810cd5 100644
--- a/t/04cgi.t
+++ b/t/04cgi.t
@@ -21,7 +21,7 @@ my %envvars=(
SERVER_PORT => 'SERVER_PORT: '.$PORT,
REQUEST_METHOD => 'REQUEST_METHOD: GET',
REQUEST_URI => 'REQUEST_URI: /cgitest/REQUEST_URI',
- SERVER_PROTOCOL => 'SERVER_PROTOCOL: HTTP/0.9',
+ SERVER_PROTOCOL => 'SERVER_PROTOCOL: HTTP/1.1',
SERVER_NAME => "SERVER_NAME: $host",
SERVER_SOFTWARE => 'SERVER_SOFTWARE: HTTP::Server::Simple/\d+.\d+',
REMOTE_ADDR => 'REMOTE_ADDR: 127.0.0.1',
@@ -43,7 +43,7 @@ my %envvars=(
foreach my $method (keys(%methods)) {
like(
- fetch("GET /cgitest/$method"),
+ fetch("GET /cgitest/$method HTTP/1.1",""),
"/$methods{$method}/",
"method - $method"
);
@@ -52,7 +52,7 @@ my %envvars=(
foreach my $envvar (keys(%envvars)) {
like(
- fetch("GET /cgitest/$envvar"),
+ fetch("GET /cgitest/$envvar HTTP/1.1",""),
"/$envvars{$envvar}/",
"Environment - $envvar"
);
@@ -78,71 +78,45 @@ my %envvars=(
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;
-
-
+ my $hostname = "localhost";
+ my $port = $PORT;
+ my $message = join "", map { "$_\015\012" } @_;
+ my $timeout = 5;
+ my $response;
+
+ eval {
+ local $SIG{ALRM} = sub { die "early exit - SIGALRM caught" };
+ alarm $timeout*2; #twice longer than timeout used later by select()
+
+ my $iaddr = inet_aton($hostname) || die "inet_aton: $!";
+ my $paddr = sockaddr_in($port, $iaddr) || die "sockaddr_in: $!";
+ my $proto = getprotobyname('tcp') || die "getprotobyname: $!";
+ socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ connect(SOCK, $paddr) || die "connect: $!";
+ (send SOCK, $message, 0) || die "send: $!";
+
+ my $rvec = '';
+ vec($rvec, fileno(SOCK), 1) = 1;
+ die "vec(): $!" unless $rvec;
+
+ $response = '';
+ for (;;) {
+ my $r = select($rvec, undef, undef, $timeout);
+ die "select: timeout - no data to read from server" unless ($r > 0);
+ my $l = sysread(SOCK, $response, 1024, length($response));
+ die "sysread: $!" unless defined($l);
+ last if ($l == 0);
+ }
+ $response =~ s/\015\012/\n/g;
+ (close SOCK) || die "close(): $!";
+ alarm 0;
+ };
+ if ($@) {
+ return "[ERROR] $@";
+ }
+ else {
+ return $response;
+ }
}
{
@@ -172,3 +146,4 @@ sub fetch {
}
}
+
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list