Test::HTTP::Server::Simple - Test::More functions for HTTP::Server::Simple

    package My::WebServer;
    use base qw/Test::HTTP::Server::Simple HTTP::Server::Simple/;

    package main;
    use Test::More tests => 42;

    my $s = My::WebServer->new;

    my $url_root = $s->started_ok("start up my web server);

    # connect to "$url_root/cool/site" and test with Test::WWW::Mechanize,
    # Test::HTML::Tidy, etc

  

package Test::HTTP::Server::Simple;

our $VERSION = '0.11';

use warnings;
use strict;
use Carp;

use NEXT;

use Test::Builder;
my $Tester = Test::Builder->new;

use constant WIN32 => $^O =~ /win32/i;

my $Event; # used on win32 only
if (WIN32) {
    require Win32::Event;
    $Event = Win32::Event->new();
}

my @CHILD_PIDS;

# If an interrupt kills perl, END blocks are not run.  This
# essentially converts interrupts (like CTRL-C) into a standard
# perl exit (even if we're inside an eval {}).
$SIG{INT} = sub { exit };

# In case the surrounding 'prove' or similar harness got the SIGINT
# before we did, and hence STDERR is closed.
$SIG{PIPE} = 'IGNORE';

END {
    local $?;
    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;
        sleep 1;
        foreach (@CHILD_PIDS) {
            sleep 1 while kill 0, $_;
        }
    }
    else {
        @CHILD_PIDS = grep {kill 0, $_} @CHILD_PIDS;
        if (@CHILD_PIDS) {
            kill 'USR1', @CHILD_PIDS;
            local $SIG{ALRM} = sub {
                use POSIX ":sys_wait_h";
                my @last_chance = grep { waitpid($_, WNOHANG) == -1 }
                    grep { kill 0, $_ } @CHILD_PIDS;
                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;
            };
            die $@ if $@;
            alarm(0);
        }
    }
} 

sub started_ok {
    my $self = shift;
    my $text   = shift;
    $text = 'started server' unless defined $text;

    my $port = $self->port;
    my $pid;

    $self->{'test_http_server_simple_parent_pid'} = $$;

    my $child_loaded_yet = 0;

    # So this is a little complicated.  The following signal handler does two
    # ENTIRELY DIFFERENT things:
    #
    #  In the parent, it just sets $child_loaded_yet, which breaks out of the
    #  while loop below.  It's activated by the kid sending it a SIGUSR1 after
    #  it runs setup_listener
    #
    #  In the kid, it sets the variable, but that's basically pointless since
    #  the call to ->background doesn't actually return in the kid.  But also,
    #  it exits.  And when you actually exit with 'exit' (as opposed to being
    #  killed by a signal) END blocks get run.  Which means that you can use
    #  Devel::Cover to test the kid's coverage.  This one is activated by the
    #  parent's END block in this file.

    local %SIG;
    if (not WIN32) {
        $SIG{'USR1'} = sub { $child_loaded_yet = 1; exit unless $self->{'test_http_server_simple_parent_pid'} == $$ }
    }

    # XXX TODO FIXME should somehow not have the signal handler around in the
    # kid
    # Comment: How about if ($pid) { $SIG{'USR1'} = ... }?
    
    eval { $pid = $self->background; };

    if ($@) {
        my $error_text = $@;  # In case the next line changes it.
        $Tester->ok(0, $text);
        $Tester->diag("HTTP::Server::Simple->background failed: $error_text");
        return;
    }

    unless ($pid =~ /^-?\d+$/) {
        $Tester->ok(0, $text);
        $Tester->diag("HTTP::Server::Simple->background didn't return a valid PID");
        return;
    } 

    push @CHILD_PIDS, $pid;

    if (WIN32) {
        $Event->wait();
    }
    else {
        1 while not $child_loaded_yet;
    }

    $Tester->ok(1, $text);

    return "http://localhost:$port";
}

sub setup_listener {
    my $self = shift;
    $self->NEXT::setup_listener;
    if (WIN32) {
        $Event->pulse();
    }
    else {
        kill 'USR1', $self->{'test_http_server_simple_parent_pid'};
    }
}

sub pids {
    return @CHILD_PIDS;
}

1;