Attached is a a patch for HTTP::Server::Simple that i believe implements proper IPv6 support without adding any non-core dependencies. It keeps the same interface changes as the original patch by Mats (optional $family argument to new(), new family() method on the object, all defaulting to AF_INET).
The patch also modifies the test suite to perform IPv4 and IPv6 tests.
I've tested it and it works against perl 5.14 (i think that's Socket
1.94), but it fails against perl 5.10 (Socket 1.82, afaict). I can't
find the full history of Socket to figure out where the relevant symbols
(Socket::IN6ADDR_ANY and Socket::getaddrinfo) were added.
Maybe you want to also make the "use Socket;" line have a version number
if you know the correct cutoff.
Please let me know if you have any trouble or concerns with it, or if
you need me to modify it some way to consider accepting it.
Regards,
--dkg
diff --git a/lib/HTTP/Server/Simple.pm b/lib/HTTP/Server/Simple.pm
index 50479ae..5905d55 100755
--- a/lib/HTTP/Server/Simple.pm
+++ b/lib/HTTP/Server/Simple.pm
@@ -124,15 +124,17 @@ could kill the server.
=head1 METHODS
-=head2 HTTP::Server::Simple->new($port)
+=head2 HTTP::Server::Simple->new($port, $family)
API call to start a new server. Does not actually start listening
-until you call C<-E<gt>run()>. If omitted, C<$port> defaults to 8080.
+until you call C<-E<gt>run()>. If omitted, C<$port> defaults to 8080,
+and C<$family> defaults to L<Socket::AF_INET>.
+The alternative domain is L<Socket::AF_INET6>.
=cut
sub new {
- my ( $proto, $port ) = @_;
+ my ( $proto, $port, $family ) = @_;
my $class = ref($proto) || $proto;
if ( $class eq __PACKAGE__ ) {
@@ -143,6 +145,7 @@ sub new {
my $self = {};
bless( $self, $class );
$self->port( $port || '8080' );
+ $self->family( $family || AF_INET );
return $self;
}
@@ -151,7 +154,7 @@ sub new {
=head2 lookup_localhost
Looks up the local host's IP address, and returns it. For most hosts,
-this is C<127.0.0.1>.
+this is C<127.0.0.1>, or possibly C<::1>.
=cut
@@ -159,9 +162,14 @@ sub lookup_localhost {
my $self = shift;
my $local_sockaddr = getsockname( $self->stdio_handle );
- my ( undef, $localiaddr ) = sockaddr_in($local_sockaddr);
- $self->host( gethostbyaddr( $localiaddr, AF_INET ) || "localhost");
- $self->{'local_addr'} = inet_ntoa($localiaddr) || "127.0.0.1";
+ my $local_family = sockaddr_family($local_sockaddr);
+ my ( undef, $localiaddr ) =
+ ($local_family == AF_INET6) ? sockaddr_in6($local_sockaddr)
+ : sockaddr_in($local_sockaddr);
+
+ $self->host( gethostbyaddr( $localiaddr, $local_family ) || "localhost");
+ $self->{'local_addr'} = Socket::inet_ntop($local_family, $localiaddr)
+ || (($local_family == AF_INET6) ? "::1" : "127.0.0.1");
}
@@ -180,6 +188,31 @@ sub port {
}
+=head2 family [NUMBER]
+
+Takes an optional address family for this server to use. Valid values
+are Socket::AF_INET and Socket::AF_INET6. All other values are silently
+changed into Socket::AF_INET for backwards compatibility with previous
+versions of the module.
+
+Returns the address family of the present listening socket. (Defaults to
+Socket::AF_INET.)
+
+=cut
+
+sub family {
+ my $self = shift;
+ if (@_) {
+ if ($_[0] == AF_INET || $_[0] == AF_INET6) {
+ $self->{'family'} = shift;
+ } else {
+ $self->{'family'} = AF_INET;
+ }
+ }
+ return ( $self->{'family'} );
+
+}
+
=head2 host [address]
Takes an optional host address for this server to bind to.
@@ -359,8 +392,15 @@ sub _process_request {
# ( http://dev.catalyst.perl.org/changeset/5195, 5221 )
my $remote_sockaddr = getpeername( $self->stdio_handle );
- my ( $iport, $iaddr ) = $remote_sockaddr ? sockaddr_in($remote_sockaddr) : (undef,undef);
- my $peeraddr = $iaddr ? ( inet_ntoa($iaddr) || "127.0.0.1" ) : '127.0.0.1';
+ my $family = sockaddr_family($remote_sockaddr);
+
+ my ( $iport, $iaddr ) = $remote_sockaddr
+ ? ( ($family == AF_INET6) ? sockaddr_in6($remote_sockaddr)
+ : sockaddr_in($remote_sockaddr) )
+ : (undef,undef);
+
+ my $loopback = ($family == AF_INET6) ? "::1" : "127.0.0.1";
+ my $peeraddr = $iaddr ? ( Socket::inet_ntop($family, $iaddr) || $loopback ) : $loopback;
my ( $method, $request_uri, $proto ) = $self->parse_request;
@@ -650,18 +690,34 @@ sub setup_listener {
my $self = shift;
my $tcp = getprotobyname('tcp');
- socket( HTTPDaemon, PF_INET, SOCK_STREAM, $tcp ) or croak "socket: $!";
+ my $sockaddr;
+ socket( HTTPDaemon, $self->{'family'}, SOCK_STREAM, $tcp )
+ or croak "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
- )
- )
- )
+
+ if ($self->host) { # Explicit listening address
+ my ($err, @res) = Socket::getaddrinfo($self->host, $self->port, { family => $self->{'family'}, socktype => SOCK_STREAM } );
+ warn "$err!"
+ if ($err);
+ # we're binding only to the first returned address in the requested family.
+ while ($a = shift(@res)) {
+ # Be certain on the address family.
+ # TODO Accept AF_UNSPEC, reject SITE-LOCAL
+ next unless ($self->{'family'} == $a->{'family'});
+
+ # Use the first plausible address.
+ $sockaddr = $a->{'addr'};
+ last;
+ }
+ }
+ else { # Use the wildcard address
+ $sockaddr = ($self->{'family'} == AF_INET6)
+ ? sockaddr_in6($self->port(), Socket::IN6ADDR_ANY)
+ : sockaddr_in($self->port(), INADDR_ANY);
+ }
+
+ bind( HTTPDaemon, $sockaddr)
or croak "bind to @{[$self->host||'*']}:@{[$self->port]}: $!";
listen( HTTPDaemon, SOMAXCONN ) or croak "listen: $!";
}
diff --git a/t/01live.t b/t/01live.t
index 4d0587d..cd58b98 100644
--- a/t/01live.t
+++ b/t/01live.t
@@ -1,7 +1,7 @@
# -*- perl -*-
use Socket;
-use Test::More tests => 14;
+use Test::More tests => 34;
use strict;
# This script assumes that `localhost' will resolve to a local IP
@@ -31,33 +31,34 @@ my $DEBUG = 1 if @ARGV;
my @pids = ();
my @classes = (qw(HTTP::Server::Simple SlowServer));
for my $class (@classes) {
- run_server_tests($class);
+ run_server_tests($class, AF_INET);
+ run_server_tests($class, AF_INET6);
$PORT++; # don't reuse the port incase your bogus os doesn't release in time
}
-
-{
- my $s=HTTP::Server::Simple::CGI->new($PORT);
+for my $fam ( AF_INET, AF_INET6 ) {
+ my $s=HTTP::Server::Simple::CGI->new($PORT, $fam);
+ is($fam, $s->family(), 'family OK');
$s->host("localhost");
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
- my $content=fetch("GET / HTTP/1.1", "");
+ my $content=fetch($fam, "GET / HTTP/1.1", "");
like($content, '/Congratulations/', "Returns a page");
eval {
- like(fetch("GET a bogus request"),
+ like(fetch($fam, "GET a bogus request"),
'/bad request/i',
"knows what a request isn't");
};
fail("got exception in client: $@") if $@;
- like(fetch("GET / HTTP/1.1", ""), '/Congratulations/',
+ like(fetch($fam, "GET / HTTP/1.1", ""), '/Congratulations/',
"HTTP/1.1 request");
- like(fetch("GET /"), '/Congratulations/',
+ like(fetch($fam, "GET /"), '/Congratulations/',
"HTTP/0.9 request");
is(kill(9,$pid),1,'Signaled 1 process successfully');
@@ -68,29 +69,43 @@ 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 = "localhost";
my $port = $PORT;
my $message = join "", map { "$_\015\012" } @_;
- my $timeout = 5;
- my $response;
-
+ 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 $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: $!";
+
+ my $paddr;
+ my ($err, @res) = Socket::getaddrinfo($hostname, $port, { family => $family,
+ socktype => $socktype,
+ protocol => $proto });
+ die "getaddrinfo: $err"
+ 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;
+ die "vec(): $!" unless $rvec;
$response = '';
- for (;;) {
+ 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));
@@ -100,18 +115,20 @@ sub fetch {
$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 $s = $class->new($PORT);
+ 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 $pid=$s->background();
@@ -119,7 +136,7 @@ sub run_server_tests {
like($pid, '/^-?\d+$/', 'pid is numeric');
- my $content=fetch("GET / HTTP/1.1", "");
+ my $content=fetch($fam, "GET / HTTP/1.1", "");
like($content, '/Congratulations/', "Returns a page");
push @pids, $pid;
diff --git a/t/04cgi.t b/t/04cgi.t
index 1b6a5e1..55567d2 100644
--- a/t/04cgi.t
+++ b/t/04cgi.t
@@ -1,3 +1,5 @@
+# -*- perl -*-
+
use Test::More;
use Socket;
use strict;
pgppa9EDlZycp.pgp
Description: PGP signature
