| Subject: | Patch to allow using Net::Server::Fork |
This is a great module! I was using it to test an application using
HTTP::Async and found I needed my test servers to respond asynchronously
as well to fully test the process. I needed to proxy the requests as
well, so I borrowed a page from the tests for HTTP::Async, as follows:
--- TestServer.pm
package TestServer;
use base qw/Test::HTTP::Server::Simple HTTP::Server::Simple::CGI/;
sub handle_request {
... [verbatim]
}
sub act_as_proxy {
... [verbatim]
}
# local modifications follow
{ # lazy monkeypatch - should be done as a proper subclass
package Net::Server::Fork;
sub post_bind_hook {
my ($self) = @_;
kill 'USR1', $self->{server}->{_run_args}->[0];
}
}
sub background {
my ($self) = @_; # Test::HTTP::Server::Simple::started_ok() does not
pass arguments
$self->SUPER::background($self->{test_http_server_simple_parent_pid});
}
sub net_server { # for asynchronous request handling - requires this class
my ($self) = @_;
'Net::Server::Fork' if $self->port & 1 ; # odd numbered ports are
forking
}
1;
Then, with Test::Class, I used a startup test that opened a TestServer
instance as a local proxy, persistent through all tests. The
setup/teardown methods created and then destroyed additional test server
instances, one per regular test method.
The teardown method was like this:
sub teardown_server : Test(teardown) {
my ($self) = @_;
if ($self->{server} && $self->{server}->pids) {
for my $pid ($self->{server}->pids) {
next if $pid == $self->{proxy_pid};
kill 'USR1', $pid; # signal to cleanly exit
waitpid $pid, 0;
}
}
$self->{server} = undef;
}
Ultimately I found that killing off a server was likely to kill my proxy
instance as well, because the additional test servers inherited the
@CHILD_PIDS array from the parent process, thinking the parent's
children were its own when the END { } block ran.
I worked around that by using a different signal in the teardown until
it came time to use Net::Server::Fork. Then I saw I had to fix the
handling of @CHILD_PIDS. The patch converts this array to a hash keyed
on the parent PID ($$).
Using:
Test-HTTP-Server-Simple-0.11
$ perl -v
This is perl 5, version 12, subversion 3 (v5.12.3) built for
i486-linux-thread-multi
$ uname -a
Linux giuseppe 2.6.37.6-smp #2 SMP Sat Apr 9 23:39:07 CDT 2011 i686
Pentium(R) Dual-Core CPU E6300 @ 2.80GHz GenuineIntel GNU/Linux
| Subject: | TestServer.pm |
use strict;
use warnings;
# Provide a simple server that can be used to test the various bits.
package TestServer;
use base qw/Test::HTTP::Server::Simple HTTP::Server::Simple::CGI/;
use Time::HiRes qw(sleep time);
use Data::Dumper;
use LWP::UserAgent;
sub handle_request {
my ( $self, $cgi ) = @_;
my $params = $cgi->Vars;
# If we are on port 8081 then we are a proxy - we should forward the
# requests.
return act_as_proxy(@_) if $self->port == 8081;
# We should act as a final destination server and so expect an absolute URL.
my $request_uri = $ENV{REQUEST_URI};
if ( $request_uri !~ m!^/! ) {
warn "ERROR - not absolute request_uri '$request_uri'";
return;
}
# Flush the output so that it goes straight away. Needed for the timeout
# trickle tests.
$self->stdout_handle->autoflush(1);
# warn "START REQUEST - " . time;
# warn Dumper($params);
# Do the right thing depending on what is asked of us.
if ( exists $params->{redirect} ) {
my $num = $params->{redirect} || 0;
$num--;
if ( $num > 0 ) {
print $cgi->redirect( -uri => "?redirect=$num", -nph => 1, );
print "You are being redirected...";
}
else {
print $cgi->header( -nph => 1 );
print "No longer redirecting";
}
}
elsif ( exists $params->{delay} ) {
sleep( $params->{delay} );
print $cgi->header( -nph => 1 );
print "Delayed for '$params->{delay}'.\n";
}
elsif ( exists $params->{trickle} ) {
print $cgi->header( -nph => 1 );
my $trickle_for = $params->{trickle};
my $finish_at = time + $trickle_for;
local $| = 1;
while ( time <= $finish_at ) {
print time . " trickle $$\n";
sleep 0.1;
}
print "Trickled for '$trickle_for'.\n";
}
elsif ( exists $params->{bad_header} ) {
my $headers = $cgi->header( -nph => 1, );
# trim trailing whitspace to single newline.
$headers =~ s{ \s* \z }{\n}xms;
# Add a bad header:
$headers .= "Bad header: BANG!\n";
print $headers . "\n\n";
print "Produced some bad headers.";
}
elsif ( my $when = $params->{break_connection} ) {
for (1) {
last if $when eq 'before_headers';
print $cgi->header( -nph => 1 );
last if $when eq 'before_content';
print "content\n";
}
}
elsif ( my $id = $params->{set_time} ) {
my $now = time;
print $cgi->header( -nph => 1 );
print "$id\n$now\n";
}
elsif ( exists $params->{not_modified} ) {
my $last_modified = HTTP::Date::time2str( time - 60 * 60 * 24 );
print $cgi->header(
-status => '304',
-nph => 1,
'Last-Modified' => $last_modified,
);
print "content\n";
}
else {
warn "DON'T KNOW WHAT TO DO: " . Dumper $params;
}
# warn "STOP REQUEST - " . time;
}
sub act_as_proxy {
my ( $self, $cgi ) = @_;
my $request_uri = $ENV{REQUEST_URI};
# According to the RFC the request_uri must be fully qualified if the
# request is to a proxy and absolute if it is to a destination server. CHeck
# that this is the case.
#
# http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html#sec5.1.2
if ( $request_uri !~ m!^http://! ) {
warn "ERROR - not fully qualified request_uri '$request_uri'";
return;
}
my $response = LWP::UserAgent->new( max_redirect => 0 )->get($request_uri);
# Add a header so that we know that this was proxied.
$response->header( WasProxied => 'yes' );
print $response->as_string;
return 1;
}
{
package Net::Server::Fork;
sub post_bind_hook {
my ($self) = @_;
kill 'USR1', $self->{server}->{_run_args}->[0];
}
}
sub background {
my ($self) = @_; # Test::HTTP::Server::Simple::started_ok() does not pass arguments
$self->SUPER::background($self->{test_http_server_simple_parent_pid});
}
sub net_server { # for asynchronous request handling - requires this class
my ($self) = @_;
'Net::Server::Fork' if $self->port & 1 ; # odd numbered ports are forking
}
1;
__END__
This module from the tests of HTTP::Async, which has the following licensing:
Copyright (C) 2006, Edmund von der Burg
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
| Subject: | handle_child_pids.patch |
--- Test/HTTP/Server/Simple.pm 2009-11-10 14:11:45.000000000 -0500
+++ Test/HTTP/Server/Simple.pm 2012-08-16 12:04:17.000000000 -0400
@@ -58,11 +58,18 @@
Note that if the child process dies, or never gets around to listening for connections, this
just hangs. (This may be fixed in a future version.)
-Also, it probably won't work if you use a custom L<Net::Server> in your server.
+Also, it won't work if you use a backgrounding L<Net::Server> in your server - the server
+loses track of its child PIDs.
=cut
-my @CHILD_PIDS;
+# This used to be a simple private array, but a second test server might think
+# the first server was one of its children (and so on for additional servers).
+# Unless you terminate all the servers at once, they tend to kill each other
+# off unexpectedly.
+# So we now use a hash indexed by $PROCESS_ID, so only a parent process will
+# see that it has children to kill when it exits.
+my %CHILD_PIDS;
# If an interrupt kills perl, END blocks are not run. This
# essentially converts interrupts (like CTRL-C) into a standard
@@ -78,29 +85,29 @@
if (WIN32) {
# INT won't do since the server is doing a blocking read
# which isn't interrupted by anything but KILL on win32.
- kill 9, $_ for @CHILD_PIDS;
+ kill 9, $_ for pids();
sleep 1;
- foreach (@CHILD_PIDS) {
+ foreach (pids()) {
sleep 1 while kill 0, $_;
}
}
else {
- @CHILD_PIDS = grep {kill 0, $_} @CHILD_PIDS;
- if (@CHILD_PIDS) {
- kill 'USR1', @CHILD_PIDS;
+ my @children = grep {kill 0, $_} pids();
+ if (@children) {
+ kill 'USR1', @children;
local $SIG{ALRM} = sub {
use POSIX ":sys_wait_h";
my @last_chance = grep { waitpid($_, WNOHANG) == -1 }
- grep { kill 0, $_ } @CHILD_PIDS;
+ grep { kill 0, $_ } @children;
die 'uncleaned Test::HTTP::Server::Simple processes: '.join(',',@last_chance)
if @last_chance;
};
alarm(5);
eval {
my $pid;
- @CHILD_PIDS = grep {$_ != $pid} @CHILD_PIDS
- while $pid = wait and $pid > 0 and @CHILD_PIDS;
- @CHILD_PIDS = () if $pid == -1;
+ @children = grep {$_ != $pid} @children
+ while $pid = wait and $pid > 0 and @children;
+ @children = () if $pid == -1;
};
die $@ if $@;
alarm(0);
@@ -158,7 +165,7 @@
return;
}
- push @CHILD_PIDS, $pid;
+ push @{ $CHILD_PIDS{$$} }, $pid;
if (WIN32) {
$Event->wait();
@@ -202,7 +209,7 @@
=cut
sub pids {
- return @CHILD_PIDS;
+ return @{ $CHILD_PIDS{$$} || [] };
}
=head1 DEPENDENCIES