1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
|
package TestServer;
use warnings;
use strict;
use Test::More;
use HTTP::Server::Simple::CGI;
use base qw( HTTP::Server::Simple::CGI );
my $dispatch_table = {};
=head1 OVERLOADED METHODS
=cut
our $pid;
sub new {
die 'An instance of TestServer has already been started.' if $pid;
my $class = shift;
my $port = shift;
if ( !$port ) {
$port = int(rand(20000)) + 20000;
}
my $self = $class->SUPER::new( $port );
my $root = $self->root;
return $self;
}
sub run {
my $self = shift;
$pid = $self->SUPER::run(@_);
$SIG{__DIE__} = \&stop;
return $pid;
}
sub handle_request {
my $self = shift;
my $cgi = shift;
my $path = $cgi->path_info();
my $handler = $dispatch_table->{$path};
if (ref($handler) eq "CODE") {
print "HTTP/1.0 200 OK\r\n";
$handler->($cgi);
}
else {
my $file = $path;
if ( $file =~ m{/$} ) {
$file .= 'index.html';
}
$file =~ s/\s+//g;
my $filename = "t/html/$file";
if ( -r $filename ) {
if (my $response=do { local (@ARGV, $/) = $filename; <> }) {
print "HTTP/1.0 200 OK\r\n";
print "Content-Type: text/html\r\nContent-Length: ", length($response), "\r\n\r\n", $response;
return;
}
}
else {
print "HTTP/1.0 404 Not found\r\n";
print
$cgi->header,
$cgi->start_html('Not found'),
$cgi->h1('Not found'),
$cgi->end_html;
}
}
}
=head1 METHODS UNIQUE TO TestServer
=cut
sub set_dispatch {
my $self = shift;
$dispatch_table = shift;
return;
}
sub background {
my $self = shift;
$pid = $self->SUPER::background()
or Carp::confess( q{Can't start the test server} );
sleep 1; # background() may come back prematurely, so give it a second to fire up
my $root = $self->root;
diag( "Test server $root as PID $pid" );
return $pid;
}
sub hostname {
my $self = shift;
return '127.0.0.1';
}
sub root {
my $self = shift;
my $port = $self->port;
my $hostname = $self->hostname;
return "http://$hostname:$port";
}
sub stop {
if ( $pid ) {
kill( 9, $pid ) unless $^S;
undef $pid;
}
return;
}
1;
|