diff options
Diffstat (limited to 't')
| -rw-r--r-- | t/00smoke.t | 11 | ||||
| -rw-r--r-- | t/01live.t | 186 | ||||
| -rw-r--r-- | t/02pod.t | 9 | ||||
| -rw-r--r-- | t/03podcoverage.t | 9 | ||||
| -rw-r--r-- | t/04cgi.t | 207 |
5 files changed, 422 insertions, 0 deletions
diff --git a/t/00smoke.t b/t/00smoke.t new file mode 100644 index 0000000..8e6cb95 --- /dev/null +++ b/t/00smoke.t @@ -0,0 +1,11 @@ +use Test::More tests=>8; + +use_ok(HTTP::Server::Simple); +ok(HTTP::Server::Simple->can('new'), 'can new()'); +my $s= HTTP::Server::Simple->new(); +isa_ok($s,'HTTP::Server::Simple'); +is($s->port(),8080,'Defaults to 8080'); +is($s->port(13432),13432,'Can change port'); +is($s->port(),13432,'Change persists'); +ok($s->can('print_banner'), 'can print_banner()'); +ok($s->can('run'), 'can run()'); diff --git a/t/01live.t b/t/01live.t new file mode 100644 index 0000000..69891c4 --- /dev/null +++ b/t/01live.t @@ -0,0 +1,186 @@ +# -*- perl -*- + +use Socket; +use Test::More; +use strict; + +# This script assumes that `localhost' will resolve to a local IP +# address that may be bound to, + +my $PORT = 40000 + int(rand(10000)); +my $RUN_IPV6 = eval { + my $ipv6_host = get_localhost(AF_INET6); + socket my $sockh, Socket::PF_INET6(), SOCK_STREAM, 0 or die "Cannot socket(PF_INET6) - $!"; + my ($err, @res) = Socket::getaddrinfo($ipv6_host, $PORT, { family => AF_INET6, socktype => SOCK_STREAM } ); + diag $err if $err; + for my $r (@res) { + next unless ($r->{'family'} == AF_INET6); + bind $sockh, $r->{'addr'} or die "Cannot bind - $!"; + last; + } + return 1; +}; +if ( $RUN_IPV6) { + plan tests => 34; +} else { + diag("Skipping IPv6"); + plan tests => 17; +} +use HTTP::Server::Simple; + +package SlowServer; +# This test class just waits a while before it starts +# accepting connections. This makes sure that CPAN #28122 is fixed: +# background() shouldn't return prematurely. + +use base qw(HTTP::Server::Simple::CGI); +sub setup_listener { + my $self = shift; + $self->SUPER::setup_listener(); + sleep 2; +} +1; +package main; + +my $DEBUG = 1 if @ARGV; + +my @pids = (); +my @classes = (qw(HTTP::Server::Simple SlowServer)); +for my $class (@classes) { + run_server_tests($class, AF_INET); + run_server_tests($class, AF_INET6) if $RUN_IPV6; + $PORT++; # don't reuse the port incase your bogus os doesn't release in time +} + + +for my $fam ( AF_INET, AF_INET6 ) { + next if ($fam == AF_INET6 && not $RUN_IPV6); + my $s=HTTP::Server::Simple::CGI->new($PORT, $fam); + is($fam, $s->family(), 'family OK'); + $s->host(get_localhost($fam)); + my $pid=$s->background(); + diag("started server PID='$pid'") if ($ENV{'TEST_VERBOSE'}); + like($pid, '/^-?\d+$/', 'pid is numeric'); + select(undef,undef,undef,0.2); # wait a sec + SKIP: { + skip "No localhost for $fam", 4 unless defined $s->host; + my $content=fetch($fam, "GET / HTTP/1.1", ""); + like($content, '/Congratulations/', "Returns a page"); + + eval { + like(fetch($fam, "GET a bogus request"), + '/bad request/i', + "knows what a request isn't"); + }; + fail("got exception in client: $@") if $@; + + like(fetch($fam, "GET / HTTP/1.1", ""), '/Congratulations/', + "HTTP/1.1 request"); + + like(fetch($fam, "GET /"), '/Congratulations/', + "HTTP/0.9 request"); + } + + is(kill(9,$pid),1,'Signaled 1 process successfully'); +} + +is( kill( 9, $_ ), 1, "Killed PID: $_" ) for @pids; + +# this function may look excessive, but hopefully will be very useful +# in identifying common problems +sub fetch { + my $family = shift; + my $hostname = get_localhost($family); + my $port = $PORT; + my $message = join "", map { "$_\015\012" } @_; + my $timeout = 5; + my $response; + my $proto = getprotobyname('tcp') || die "getprotobyname: $!"; + my $socktype = SOCK_STREAM; + + eval { + local $SIG{ALRM} = sub { die "early exit - SIGALRM caught" }; + alarm $timeout*2; #twice longer than timeout used later by select() + + my $paddr; + my ($err, @res) = Socket::getaddrinfo($hostname, $port, { family => $family, + socktype => $socktype, + protocol => $proto }); + die "getaddrinfo: $err operating on [$hostname] [$port] [$family] [$socktype] [$proto]" + if ($err); + while ($a = shift(@res)) { + next unless ($family == $a->{'family'}); + next unless ($proto == $a->{'protocol'}); + next unless ($socktype == $a->{'socktype'}); + + $paddr = $a->{'addr'}; + last + } + socket(SOCK, $family, $socktype, $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 { + my $class = shift; + my $fam = shift; + my $s = $class->new($PORT, $fam); + is($s->family(), $fam, 'constructor set family properly'); + is($s->port(),$PORT,"Constructor set port correctly"); + + my $localhost = get_localhost($fam); + $s->host($localhost); # otherwise we bind to * which doesn't work on all systems + + my $pid=$s->background(); + select(undef,undef,undef,0.2); # wait a sec + + like($pid, '/^-?\d+$/', 'pid is numeric'); + + SKIP: { + skip "No localhost defined for $fam", 1 unless defined $localhost; + my $content=fetch($fam, "GET / HTTP/1.1", ""); + + like($content, '/Congratulations/', "Returns a page"); + } + push @pids, $pid; +} + +{ + my %localhost; +sub get_localhost { + my $family = shift; + + return $localhost{$family} if $localhost{$family}; + + if ($family == AF_INET) { + $localhost{$family} = gethostbyaddr(INADDR_LOOPBACK,$family); + } else { + $localhost{$family} = gethostbyaddr(Socket::IN6ADDR_LOOPBACK,$family); + } + return $localhost{$family}; + +} +} diff --git a/t/02pod.t b/t/02pod.t new file mode 100644 index 0000000..0f0480b --- /dev/null +++ b/t/02pod.t @@ -0,0 +1,9 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; +all_pod_files_ok(); + diff --git a/t/03podcoverage.t b/t/03podcoverage.t new file mode 100644 index 0000000..6609207 --- /dev/null +++ b/t/03podcoverage.t @@ -0,0 +1,9 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More; + +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; +all_pod_coverage_ok({ also_private => [ '/^[A-Z_]+$/' ], }); + diff --git a/t/04cgi.t b/t/04cgi.t new file mode 100644 index 0000000..76b117f --- /dev/null +++ b/t/04cgi.t @@ -0,0 +1,207 @@ +# -*- perl -*- + +use Test::More; +use Socket; +use strict; + +my $PORT = 40000 + int(rand(10000)); + +my $host = gethostbyaddr(inet_aton('localhost'), AF_INET); + +my %methods=( + url => "url: http://$host:".$PORT, + path_info => 'path_info: /cgitest/path_info', + server_name => "server_name: $host", + server_port => 'server_port: '.$PORT, + server_software => 'server_software: HTTP::Server::Simple/\d+.\d+', + request_method => 'request_method: GET', + raw_cookie => undef, # do not test + ); + +my %envvars=( + SERVER_URL => "SERVER_URL: http://$host:".$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: $host", + SERVER_SOFTWARE => 'SERVER_SOFTWARE: HTTP::Server::Simple/\d+.\d+', + REMOTE_ADDR => 'REMOTE_ADDR: 127.0.0.1', + QUERY_STRING => 'QUERY_STRING: ', + PATH_INFO => 'PATH_INFO: /cgitest/PATH_INFO', + ); + +if ($^O eq 'freebsd' && `sysctl -n security.jail.jailed` == 1) { + delete @methods{qw(url server_name)}; + delete @envvars{qw(SERVER_URL SERVER_NAME REMOTE_ADDR)}; + plan tests => 55; +} +else { + plan tests => 60; +} + +{ + my $server=CGIServer->new($PORT); + is($server->port(),$PORT,'Constructor set port correctly'); + sleep(3); # wait just a moment + + my $pid=$server->background; + + like($pid, '/^-?\d+$/', 'pid is numeric'); + + select(undef,undef,undef,0.2); # wait a sec + my @message_tests = ( + [["GET / HTTP/1.1",""], '/NOFILE/', '[GET] no file'], + [["POST / HTTP/1.1","Content-Length: 0",""], '/NOFILE/', '[POST] no file'], + [["HEAD / HTTP/1.1",""], '/NOFILE/', '[HEAD] no file'], + [["PUT / HTTP/1.1","Content-Length: 0",""], '/NOFILE/', '[PUT] no file'], + [["DELETE / HTTP/1.1",""], '/NOFILE/', '[DELETE] no file'], + [["PATCH / HTTP/1.1","Content-Length: 0",""], '/NOFILE/', '[PATCH] no file'], + ); + foreach my $message_test (@message_tests) { + my ($message, $expected, $description) = @$message_test; + like(fetch(@$message), $expected, $description); + select(undef,undef,undef,0.2); # wait a sec + } + + foreach my $method (keys(%methods)) { + next unless defined $methods{$method}; + like( + fetch("GET /cgitest/$method HTTP/1.1",""), + "/$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",""), + "/$envvars{$envvar}/", + "Environment - $envvar" + ); + select(undef,undef,undef,0.2); # wait a sec + } + +# extra tests for HTTP/1.1 absolute URLs + + foreach my $verb ('GET', 'HEAD') { + foreach my $method (keys(%methods)) { + next unless defined $methods{$method}; + + my $method_value = $methods{$method}; + $method_value =~ s/\bGET\b/$verb/; + + like( + fetch("$verb http://localhost/cgitest/$method HTTP/1.1",""), + "/$method_value/", + "method (absolute URL) - $method" + ); + select(undef,undef,undef,0.2); # wait a sec + } + + foreach my $envvar (keys(%envvars)) { + (my $envvar_value = $envvars{$envvar}); + $envvar_value =~ s/\bGET\b/$verb/; + + like( + fetch("$verb http://localhost/cgitest/$envvar HTTP/1.1",""), + "/$envvar_value/", + "Environment (absolute URL) - $envvar" + ); + select(undef,undef,undef,0.2); # wait a sec + } + } + + like( + fetch("GET /cgitest/REQUEST_URI?foo%3Fbar HTTP/1.0",""), + qr/foo%3Fbar/, + "Didn't decode already" + ); + + like( + fetch("GET /cgitest/foo%2Fbar/PATH_INFO HTTP/1.0",""), + qr|foo/bar|, + "Did decode already" + ); + + like( + fetch("GET /cgitest/raw_cookie HTTP/1.0","Cookie: foo=bar",""), + qr|foo=bar|, + "uses HTTP_COOKIE", + ); + + is(kill(9,$pid),1,'Signaled 1 process successfully'); + wait or die "counldn't wait for sub-process completion"; +} + + +sub fetch { + 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; + } +} + +{ + package CGIServer; + use base qw(HTTP::Server::Simple::CGI); + + 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(exists $methods{$file}) { + $response = "$file: ".$cgi->$file(); + } elsif($envvars{$file}) { + $response="$file: $ENV{$file}"; + } else { + $response=$file; + } + print length($response), "\r\n\r\n", $response; + } +} + + |