[Rt-commit] r2270 - in HTTP-Server-Simple: . lib/HTTP/Server
lib/HTTP/Server/Simple t
jesse at bestpractical.com
jesse at bestpractical.com
Tue Mar 1 00:58:45 EST 2005
Author: jesse
Date: Tue Mar 1 00:58:43 2005
New Revision: 2270
Added:
HTTP-Server-Simple/lib/HTTP/Server/Simple/
HTTP-Server-Simple/lib/HTTP/Server/Simple/CGI.pm
Modified:
HTTP-Server-Simple/ (props changed)
HTTP-Server-Simple/Changes
HTTP-Server-Simple/MANIFEST
HTTP-Server-Simple/SIGNATURE
HTTP-Server-Simple/lib/HTTP/Server/Simple.pm
HTTP-Server-Simple/t/01live.t
Log:
r6106 at hualien: jesse | 2005-03-01 00:55:03 -0500
myriad changes from SAMV
Modified: HTTP-Server-Simple/Changes
==============================================================================
--- HTTP-Server-Simple/Changes (original)
+++ HTTP-Server-Simple/Changes Tue Mar 1 00:58:43 2005
@@ -1,3 +1,15 @@
+0.03_02 Thu Feb 17 23:34:00 NZDT 2005
+- Make test script not depend on LWP
+- Add ->header(), and various generic hook capabilities
+- Made HTTP::Server::Simple::CGI use those hooks
+- Add ->bad_request(), for protocol errors
+
+0.03_01 Thu Feb 17 21:39:34 NZDT 2005
+- Add ->setup() and ->handler()
+- Add support for specifying a host to bind listener to
+- Split out CGI.pm support into sub-class
+- Add Changes file to MANIFEST
+
0.03 Wed Jan 26 08:55:34 EST 2005
- Test fixes for Win32
Modified: HTTP-Server-Simple/MANIFEST
==============================================================================
--- HTTP-Server-Simple/MANIFEST (original)
+++ HTTP-Server-Simple/MANIFEST Tue Mar 1 00:58:43 2005
@@ -8,10 +8,12 @@
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/HTTP/Server/Simple.pm
+lib/HTTP/Server/Simple/CGI.pm
Makefile.PL
MANIFEST This list of files
META.yml
README
+Changes
SIGNATURE
t/00smoke.t
t/01live.t
Modified: HTTP-Server-Simple/SIGNATURE
==============================================================================
--- HTTP-Server-Simple/SIGNATURE (original)
+++ HTTP-Server-Simple/SIGNATURE Tue Mar 1 00:58:43 2005
@@ -14,8 +14,9 @@
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
-SHA1 d04d371c5a4a9639ddfbf6b16ee7984d78c76f6b MANIFEST
-SHA1 0fd109a042d8a0551dde63bd756c4c4cef2003e8 META.yml
+SHA1 0f7431386b8bf23750d29652164695a0feac4f37 Changes
+SHA1 d092b8d9bac96d321d554322e86cca2018714163 MANIFEST
+SHA1 2488f38638076522cb49fb0df360316bd4733284 META.yml
SHA1 490f3fd115e09cb05b725580e5ed5cdd58241049 Makefile.PL
SHA1 ed0c107672daac3bc9e266876666e1059dbe44b7 README
SHA1 61dac0d5f7c81522d856b2d8608538ba34fb1247 ex/sample_server
@@ -27,15 +28,16 @@
SHA1 e448c6dc5351ef425e3f8bdbeb642409120bc3ca inc/Module/Install/Metadata.pm
SHA1 134de6ff2f762873b6a1af950dd53f8e0a801d73 inc/Module/Install/Win32.pm
SHA1 1ec06df292af7f652d33db6129e9e4c7cc8b5095 inc/Module/Install/WriteAll.pm
-SHA1 e8aa3eec3ca95b6a9d08d2382ffe1915039f2a99 lib/HTTP/Server/Simple.pm
+SHA1 62bc78f251eea18ee792578ff2fb768dd605060d lib/HTTP/Server/Simple.pm
+SHA1 7ecec74634ca2edc652320d09f01996534b1660e lib/HTTP/Server/Simple/CGI.pm
SHA1 db064af54cab345a71daec576e32e64b8fb1033d t/00smoke.t
-SHA1 3f1446b341234aaf07eb27bba7a2f60b5149c579 t/01live.t
+SHA1 9e68bffc26b5a42e2785ec68c3bf6fe45d6bb6da t/01live.t
SHA1 aca95653cfce68912e08c57b3a4566207e2f99b3 t/02pod.t
SHA1 90f0be3e6b0fab021155953742f5cc5c5e47a5aa t/03podcoverage.t
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.2.5 (GNU/Linux)
-iD8DBQFB96MIEi9d9xCOQEYRAv6dAKCQ/A/RSUAI0nXjl4oJCXOVlWUllgCgpWjB
-biQWmDfILIHVJNrWgOQ2L0E=
-=yqcp
+iD8DBQFCJAOqEi9d9xCOQEYRAnMfAJ9yzAmC+OQXfyaxN7dEStSMT9af1gCfRwFC
+gPHD8N4QWmD4PtZzv0Ysf6Q=
+=hl1f
-----END PGP SIGNATURE-----
Modified: HTTP-Server-Simple/lib/HTTP/Server/Simple.pm
==============================================================================
--- HTTP-Server-Simple/lib/HTTP/Server/Simple.pm (original)
+++ HTTP-Server-Simple/lib/HTTP/Server/Simple.pm Tue Mar 1 00:58:43 2005
@@ -3,11 +3,9 @@
use strict;
use warnings;
use Socket;
-use CGI ();
+use Carp;
-my %clean_env=%ENV;
-
-our $VERSION = '0.03';
+our $VERSION = '0.03_02';
=head1 NAME
@@ -15,8 +13,9 @@
=head1 WARNING
-This code is still undergoing active development. Particularly, the API is not
-yet frozen. Comments about the API would be greatly appreciated.
+This code is still undergoing active development. Particularly, the
+API is not yet frozen. Comments about the API would be greatly
+appreciated.
=head1 SYNOPSIS
@@ -28,17 +27,34 @@
my $server = HTTP::Server::Simple->new();
$server->run();
-=head1 DESCRIPTION
+However, normally you will sub-class the HTTP::Server::Simple::CGI
+module (see L<HTTP::Server::Simple::CGI>);
-This is a simple standalone http dameon. It doesn't thread. It doesn't fork.
-It does, however, act as a simple frontend which can turn a CGI into a standalone web-based application.
+ package Your::Web::Server;
+ use base qw(HTTP::Server::Simple::CGI);
+
+ sub handle_request {
+ my ($self, $cgi) = @_;
+ #... do something, print output to default
+ # selected filehandle...
-=cut
+ }
+
+ 1;
+
+=head1 DESCRIPTION
+This is a simple standalone http dameon. It doesn't thread. It doesn't
+fork.
-=head2 new
+It does, however, act as a simple frontend which can turn a CGI into a
+standalone web-based application.
+=head2 HTTP::Server::Simple->new($port)
+
+API call to start a new server. Does not actually start listening
+until you call C<-E<gt>run()>.
=cut
@@ -46,6 +62,13 @@
sub new {
my ($proto,$port) = @_;
my $class = ref($proto) || $proto;
+
+ if ( $class eq __PACKAGE__ ) {
+ warn "HTTP::Server::Simple called directly - using CGI version";
+ require HTTP::Server::Simple::CGI;
+ return HTTP::Server::Simple::CGI->new(@_[1..$#_]);
+ }
+
my $self = {};
bless( $self, $class );
$self->port( $port || '8080');
@@ -67,10 +90,25 @@
}
-=head2 background
+=head2 host [address]
-Run the server in the background. returns pid.
+Takes an optional host address for this server to bind to.
+Returns this server's bound address (if any). Defaults to C<undef>
+(bind to all interfaces).
+
+=cut
+
+sub host {
+ my $self = shift;
+ $self->{'host'} = shift if (@_);
+ return ( $self->{'host'} );
+
+}
+
+=head2 background
+
+Run the server in the background. returns pid.
=cut
@@ -83,12 +121,12 @@
POSIX::setsid()
or die "Can't start a new session: $!";
$self->run();
-}
+}
=head2 run
-Run the server. If all goes well, this won't ever return, but it will start listening for http requests
-
+Run the server. If all goes well, this won't ever return, but it will
+start listening for http requests.
=cut
@@ -103,12 +141,15 @@
for ( ; accept( Remote, HTTPDaemon ) ; close Remote ) {
+ $self->accept_hook if $self->can("accept_hook");
+
*STDIN = *Remote;
*STDOUT = *Remote;
my $remote_sockaddr = getpeername(STDIN);
my ( undef, $iaddr ) = sockaddr_in($remote_sockaddr);
my $peername = gethostbyaddr( $iaddr, AF_INET ) || "localhost";
+
my $peeraddr = inet_ntoa($iaddr) || "127.0.0.1";
my $local_sockaddr = getsockname(STDIN);
@@ -117,31 +158,44 @@
|| "localhost";
my $localaddr = inet_ntoa($localiaddr) || "127.0.0.1";
- chomp( $_ = <STDIN> );
- my ( $method, $request_uri, $proto, undef ) = split;
+ my ( $method, $request_uri, $proto ) =
+ $self->parse_request
+ or do {$self->bad_request; next};
- my ( $file, undef, $query_string ) =
- ( $request_uri =~ /([^?]*)(\?(.*))?/ ); # split at ?
+ $proto ||= "HTTP/0.9";
- last if ( $method !~ /^(GET|POST|HEAD)$/ );
+ my ( $file, $query_string ) =
+ ( $request_uri =~ /([^?]*)(?:\?(.*))?/ ); # split at ?
- $self->build_cgi_env(
+ $self->bad_request, next
+ if ( $method !~ /^(GET|POST|HEAD)$/ );
+
+ $self->setup(
method => $method,
protocol => $proto,
query_string => ( $query_string || '' ),
+ request_uri => $request_uri,
path => $file,
- method => $method,
- port => $self->port,
+ localname => $localname,
+ localport => $self->port,
peername => $peername,
peeraddr => $peeraddr,
- localname => $localname,
- request_uri => $request_uri
);
+ # HTTP/0.9 didn't have any headers (I think)
+ if ( $proto =~ m{HTTP/(\d(\.\d)?)$} and $1 >= 1 ) {
+
+ my $headers = $self->parse_headers
+ or do{$self->bad_request; next};
+
+ $self->setup( headers => $headers
+ ) if $headers;
- my $cgi = CGI->new();
+ }
- $self->handle_request($cgi);
+ $self->post_setup_hook if $self->can("post_setup_hook");
+
+ $self->handler;
}
@@ -149,129 +203,221 @@
}
+=head1 IMPORTANT SUB-CLASS METHODS
-=head2 handle_request CGI
+A selection of these methods should be provided by sub-classes of this
+module.
-This routine is called whenever your server gets a request it can handle. It's called with a CGI object that's been pre-initialized. You want to override this method in your subclass
+=head2 handler
+This method is called after setup, with no parameters. It should
+print a valid, I<full> HTTP response to the default selected
+filehandle.
=cut
+sub handler {
+ my ( $self ) = @_;
+ if ( ref ($self) ne __PACKAGE__ ) {
+ croak "do not call ".ref($self)."::SUPER->handler";
+ } else {
+ die "handler called out of context";
+ }
+}
+
+=head2 setup(name =E<gt> $value, ...)
-sub handle_request {
- my ( $self, $cgi ) = @_;
+This method is called with a name =E<gt> value list of various things
+to do with the request. This list is given below.
- print "HTTP/1.0 200 OK\n"; # probably OK by now
- print <<EOF;
- Content-Type: text/html
- Content-Lenght: 31337
+The default setup handler simply tries to call methods with the names
+of keys of this list.
- <html><head><title>Hello!</title></head>
- <h1>Congratulations!</h1>
+ ITEM/METHOD Set to Example
+ ----------- ------------------ ------------------------
+ method Request Method "GET", "POST", "HEAD"
+ protocol HTTP version "HTTP/1.1"
+ request_uri Complete Request URI "/foobar/baz?foo=bar"
+ path Path part of URI "/foobar/baz"
+ query_string Query String undef, "foo=bar"
+ port Received Port 80, 8080
+ peername Remote name "200.2.4.5", "foo.com"
+ peeraddr Remote address "200.2.4.5", "::1"
+ localname Local interface "localhost", "myhost.com"
+ headers All HTTP/1.0+ headers (see below)
+
+The C<headers> method contains I<all> HTTP headers, in order, without
+being parsed. It is up to the sub-class to either grok them or ignore
+them.
-<body>
-<p>You now have a functional HTTP::Server::Simple running.</p>
-<p><i>(If you're seeing this page, it means you haven't subclassed HTTP::Server::Simple, which you'll need to do to make it useful.)</i></p>
- </body>
-</html>
+Note that if the client is a HTTP/0.9 client, then there will be no
+headers at all.
-EOF
+=cut
+sub setup {
+ my ( $self ) = @_;
+ while ( my ($item, $value) = splice @_, 0, 2 ) {
+ $self->$item($value) if $self->can($item);
+ }
}
+=head2 headers([Header =E<gt> $value, ...])
-=head2 setup_listener
+Receives HTTP headers and does something useful with them. This is
+called by the default C<setup()> method.
+
+You have lots of options when it comes to how you receive headers.
-This routine binds the server to a port and interface
+You can, if you really want, define C<parse_headers()> and parse them
+raw yourself.
+Secondly, you can intercept them very slightly cooked via the
+C<setup()> method, above.
+
+Thirdly, you can leave the C<setup()> header as-is (or calling the
+superclass C<setup()> for unknown request items). Then you can define
+C<headers()> in your sub-class and receive them all at once.
+
+Finally, you can define handlers to receive individual HTTP headers.
+This can be useful for very simple SOAP servers (to name a
+crack-fueled standard that defines its own special HTTP headers). Eg,
+for a header called C<Content-Length>, you would define the method
+C<content_length()> in your sub-class.
=cut
+sub headers {
+ my $self = shift;
+ my $headers = shift;
+
+ my $can_header = $self->can("header");
+ while ( my ($header, $value) = splice @$headers, 0, 2 ) {
+ if ( $can_header ) {
+ $self->header($header => $value)
+ } else {
+ (my $method = lc($header)) =~ s{-}{_}g;
+
+ # FIXME - security - this is probably very dangerous
+ # and probably OTT
+ $self->$method($value)
+ if !defined &$method # stop really dumb stuff
+ and $self->can($method);
+ }
+ }
+}
+
+=head2 accept_hook
-sub setup_listener {
+If defined by a sub-class, this method is called directly after an
+accept happens.
+
+=head2 post_setup_hook
+
+If defined by a sub-class, this method is called after all setup has
+finished, before the handler method.
+
+=head2 print_banner
+
+This routine prints a banner before the server request-handling loop
+starts.
+
+Methods below this point are probably not terribly useful to define
+yourself in subclasses.
+
+=cut
+
+sub print_banner {
my $self = shift;
- my $tcp = getprotobyname('tcp');
+ print( __PACKAGE__.": You can connect to your server at "
+ ."http://localhost:" . $self->port
+ . "/\n" );
- socket( HTTPDaemon, PF_INET, SOCK_STREAM, $tcp ) or die "socket: $!";
- setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
- or warn "setsockopt: $!";
- bind( HTTPDaemon, sockaddr_in( $self->port(), INADDR_ANY ) )
- or die "bind: $!";
- listen( HTTPDaemon, SOMAXCONN ) or die "listen: $!";
+}
+
+=head2 parse_request
+
+Parse the HTTP request line.
+
+Sub-classed versions of this should return three values - request
+method, request URI and proto
+=cut
+
+sub parse_request {
+ my $self = shift;
+ defined($_ = <STDIN>)
+ or return undef;
+ chomp;
+ m/^(\w+)\s+(\S+)(?:\s+(\S+))?\r?$/
}
-=head2 build_cgi_env
+=head2 parse_headers
-build up a CGI object out of a param hash
+Parse extra RFC822-style headers with the request.
+
+Remember, this is a B<simple> HTTP server, so nothing intelligent is
+done with them C<:-)>.
+
+This should return an ARRAY ref of C<(header =E<gt> value)> pairs
+inside the array.
=cut
-sub build_cgi_env {
+sub parse_headers {
my $self = shift;
- my %args = (
- query_string => '',
- path => '',
- port => undef,
- protocol => undef,
- localname => undef,
- method => undef,
- remote_name => undef,
- @_
- );
- %ENV=%clean_env;
+ my @headers;
+
while (<STDIN>) {
s/[\r\l\n\s]+$//;
if (/^([\w\-]+): (.+)/i) {
- my $tag = uc($1);
- $tag =~ s/^COOKIES$/COOKIE/;
- my $val = $2;
- $tag =~ s/-/_/g;
- $tag = "HTTP_" . $tag
- unless ( grep /^$tag$/, qw(CONTENT_LENGTH CONTENT_TYPE) );
- if ( $ENV{$tag} ) {
- $ENV{$tag} .= "; $val";
- } else {
- $ENV{$tag} = $val;
- }
+ push @headers, $1 => $2;
}
last if (/^$/);
}
+ \@headers;
+}
- no warnings 'uninitialized';
- $ENV{SERVER_PROTOCOL} = $args{protocol};
- $ENV{SERVER_PORT} = $args{port};
- $ENV{SERVER_NAME} = $args{'localname'};
- $ENV{SERVER_URL} =
- "http://" . $args{'localname'} . ":" . $args{'port'} . "/";
- $ENV{PATH_INFO} = $args{'path'};
- $ENV{REQUEST_URI} = $args{'request_uri'};
- $ENV{REQUEST_METHOD} = $args{method};
- $ENV{REMOTE_ADDR} = $args{'peeraddr'};
- $ENV{REMOTE_HOST} = $args{'peername'};
- $ENV{QUERY_STRING} = $args{'query_string'};
- $ENV{SERVER_SOFTWARE} ||= "HTTP::Server::Simple/$VERSION";
- CGI::initialize_globals();
-}
+=head2 setup_listener
+This routine binds the server to a port and interface.
-=head2 print_banner
+=cut
+
+sub setup_listener {
+ my $self = shift;
+
+ my $tcp = getprotobyname('tcp');
+
+ socket( HTTPDaemon, PF_INET, SOCK_STREAM, $tcp ) or die "socket: $!";
+ setsockopt( HTTPDaemon, SOL_SOCKET, SO_REUSEADDR, pack( "l", 1 ) )
+ or warn "setsockopt: $!";
+ bind( HTTPDaemon,
+ sockaddr_in( $self->port(), ( $self->host ? inet_aton($self->host)
+ : INADDR_ANY ) ) )
+ or die "bind: $!";
+ listen( HTTPDaemon, SOMAXCONN ) or die "listen: $!";
-This routine prints a banner before the server request-handling loop starts.
+}
+
+=head2 bad_request
+This method should print a valid HTTP response that says that the
+request was invalid.
=cut
-sub print_banner {
- my $self = shift;
+our $bad_request_doc = join "", <DATA>;
- print( "You can connect to your server at http://localhost:"
- . $self->port
- . "/\n" );
+sub bad_request {
+ my $self = shift;
+ print "HTTP/1.0 400 Bad request\r\n"; # probably OK by now
+ print "Content-Type: text/html\r\nContent-Length: ",
+ length($bad_request_doc), "\r\n\r\n", $bad_request_doc;
}
=head1 AUTHOR
@@ -281,7 +427,8 @@
Marcu Ramberg contributed tests, cleanup, etc
-
+Sam Vilain, <samv at cpan.org> contributed the CGI.pm split-out and
+header/setup API.
=head1 BUGS
@@ -289,9 +436,22 @@
=head1 LICENSE
-This library is free software; you can redistribute it
- and/or modify it under the same terms as Perl itself.
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
=cut
1;
+
+__DATA__
+<html>
+ <head>
+ <title>Bad Request</title>
+ </head>
+ <body>
+ <h1>Bad Request</h1>
+
+ <p>Your browser sent a request which this web server could not
+ grok.</p>
+ </body>
+</html>
Added: HTTP-Server-Simple/lib/HTTP/Server/Simple/CGI.pm
==============================================================================
--- (empty file)
+++ HTTP-Server-Simple/lib/HTTP/Server/Simple/CGI.pm Tue Mar 1 00:58:43 2005
@@ -0,0 +1,164 @@
+
+package HTTP::Server::Simple::CGI;
+
+use base qw(HTTP::Server::Simple);
+use strict;
+use warnings;
+
+use CGI ();
+
+our $VERSION = $HTTP::Server::Simple::VERSION;
+
+my %clean_env=%ENV;
+
+=head1 NAME
+
+HTTP::Server::Simple::CGI - CGI.pm-style version of HTTP::Server::Simple
+
+=head1 DESCRIPTION
+
+HTTP::Server::Simple was already simple, but some smart-ass pointed
+out that there is no CGI in HTTP, and so this module was born to
+isolate the CGI.pm-related parts of this handler.
+
+
+=head2 accept_hook
+
+The accept_hook in this sub-class clears the environment to the
+start-up state.
+
+=cut
+
+sub accept_hook {
+ %ENV= ( %clean_env,
+ SERVER_SOFTWARE => "HTTP::Server::Simple/$VERSION"
+ );
+}
+
+=head2 post_setup_hook
+
+
+
+=cut
+
+sub post_setup_hook{
+
+ $ENV{SERVER_URL} ||=
+ ("http://".$ENV{SERVER_NAME}.":".$ENV{SERVER_PORT}."/");
+
+ CGI::initialize_globals();
+}
+
+=head2 setup
+
+This method sets up environment variables based on various
+meta-headers, like the protocol, remote host name, request path, etc.
+
+=cut
+
+our %env_mapping =
+ ( protocol => "SERVER_PROTOCOL",
+ localport => "SERVER_PORT",
+ localname => "SERVER_NAME",
+ path => "PATH_INFO",
+ request_uri => "REQUEST_URI",
+ method => "REQUEST_METHOD",
+ peeraddr => "REMOTE_ADDR",
+ peername => "REMOTE_HOST",
+ query_string => "QUERY_STRING",
+ );
+
+sub setup {
+ no warnings 'uninitialized';
+ my $self = shift;
+
+ while ( my ($item, $value) = splice @_, 0, 2 ) {
+ if ( $self->can($item) ) {
+ $self->$item($value);
+ } elsif ( my $k = $env_mapping{$item} ) {
+ $ENV{$k} = $value;
+ }
+ }
+
+}
+
+=head2 headers
+
+This method sets up the process environment in icky-CGI style based on
+the HTTP input headers.
+
+=cut
+
+sub headers {
+ my $self = shift;
+ my $headers = shift;
+
+ while ( my ($tag, $value) = splice @_, 0, 2 ) {
+ $tag = uc($tag);
+ $tag =~ s/^COOKIES$/COOKIE/;
+ $tag =~ s/-/_/g;
+ $tag = "HTTP_" . $tag
+ unless $tag =~ m/^CONTENT_(?:LENGTH|TYPE)$/;
+
+ if ( exists $ENV{$tag} ) {
+ $ENV{$tag} .= "; $value";
+ } else {
+ $ENV{$tag} = $value;
+ }
+ }
+}
+
+=head2 handle_request CGI
+
+This routine is called whenever your server gets a request it can
+handle.
+
+It's called with a CGI object that's been pre-initialized.
+You want to override this method in your subclass
+
+
+=cut
+
+our $default_doc;
+$default_doc = (join "", <DATA>);
+
+sub handle_request {
+ my ( $self, $cgi ) = @_;
+
+ print "HTTP/1.0 200 OK\r\n"; # probably OK by now
+ print "Content-Type: text/html\r\nContent-Length: ",
+ length($default_doc), "\r\n\r\n", $default_doc;
+}
+
+=head2 handler
+
+Handler implemented as part of HTTP::Server::Simple API
+
+=cut
+
+sub handler {
+ my $self = shift;
+ my $cgi = new CGI();
+ $self->handle_request($cgi);
+}
+
+
+1;
+
+__DATA__
+<html>
+ <head>
+ <title>Hello!</title>
+ </head>
+ <body>
+ <h1>Congratulations!</h1>
+
+ <p>You now have a functional HTTP::Server::Simple running.
+ </p>
+
+ <p><i>(If you're seeing this page, it means you haven't subclassed
+ HTTP::Server::Simple, which you'll need to do to make it
+ useful.)</i>
+ </p>
+ </body>
+</html>
Modified: HTTP-Server-Simple/t/01live.t
==============================================================================
--- HTTP-Server-Simple/t/01live.t (original)
+++ HTTP-Server-Simple/t/01live.t Tue Mar 1 00:58:43 2005
@@ -1,18 +1,128 @@
-use Test::More;
-BEGIN {
- if (eval { require LWP::Simple }) {
- plan tests => 4;
- } else {
- Test::More->import(skip_all =>"LWP::Simple not installed: $@");
- }
-}
+# -*- perl -*-
+
+use Socket;
+use Test::More tests => 10;
+use strict;
+
+# This script assumes that `localhost' will resolve to a local IP
+# address that may be bound to,
+
+use constant PORT => 13432;
use HTTP::Server::Simple;
-my $s=HTTP::Server::Simple->new(13432);
-is($s->port(),13432,"Constructor set port correctly");
-my $pid=$s->background();
-like($pid, qr/^-?\d+$/,'pid is numeric');
-my $content=LWP::Simple::get("http://localhost:13432");
-like($content,qr/Congratulations/,"Returns a page");
-is(kill(9,$pid),1,'Signaled 1 process successfully');
+
+my $DEBUG = 1 if @ARGV;
+
+{
+ my $s=HTTP::Server::Simple->new(PORT);
+ is($s->port(),PORT,"Constructor set port correctly");
+
+ my $pid=$s->background();
+
+ like($pid, qr/^-?\d+$/,'pid is numeric');
+ select(undef,undef,undef,0.2); # wait a sec
+
+ my $content=fetch("GET / HTTP/1.1", "");
+
+ like($content, qr/Congratulations/, "Returns a page");
+ is(kill(9,$pid),1,'Signaled 1 process successfully');
+ wait or die "couldn't wait for sub-process completion";
+}
+
+{
+ my $s=HTTP::Server::Simple::CGI->new(PORT);
+ $s->host("localhost");
+ my $pid=$s->background();
+ diag("started server on $pid");
+ select(undef,undef,undef,0.2); # wait a sec
+ like($pid, qr/^-?\d+$/,'pid is numeric');
+
+ my $content=fetch("GET / HTTP/1.1", "");
+ like($content,qr/Congratulations/,"Returns a page");
+
+ eval {
+ like(fetch("GET your mum wet"), # anything does!
+ qr/bad request/i,
+ "knows what a request isn't");
+ };
+ fail("got exception in client: $@") if $@;
+
+ like(fetch("GET / HTTP/1.1", ""), qr/Congratulations/,
+ "HTTP/1.1 request");
+
+ like(fetch("GET /"), qr/Congratulations/,
+ "HTTP/0.9 request");
+
+ is(kill(9,$pid),1,'Signaled 1 process successfully');
+}
+
+# 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;
+
+
+}
More information about the Rt-commit
mailing list