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;
RT for rt.cpan.org