|
Packit |
a83d8b |
#!./perl -w
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
use strict;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
BEGIN {
|
|
Packit |
a83d8b |
unless(grep /blib/, @INC) {
|
|
Packit |
a83d8b |
chdir 't' if -d 't';
|
|
Packit |
a83d8b |
@INC = '../lib';
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
use Config;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
BEGIN {
|
|
Packit |
a83d8b |
if (-d "lib" && -f "TEST") {
|
|
Packit |
a83d8b |
my $reason;
|
|
Packit |
a83d8b |
if (! $Config{'d_fork'}) {
|
|
Packit |
a83d8b |
$reason = 'no fork';
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
elsif ($Config{'extensions'} !~ /\bSocket\b/) {
|
|
Packit |
a83d8b |
$reason = 'Socket extension unavailable';
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
elsif ($Config{'extensions'} !~ /\bIO\b/) {
|
|
Packit |
a83d8b |
$reason = 'IO extension unavailable';
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
if ($reason) {
|
|
Packit |
a83d8b |
print "1..0 # Skip: $reason\n";
|
|
Packit |
a83d8b |
exit 0;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
if ($^O eq 'MSWin32') {
|
|
Packit |
a83d8b |
print "1..0 # Skip: accept() fails for IPv6 under MSWin32\n";
|
|
Packit |
a83d8b |
exit 0;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$| = 1;
|
|
Packit |
a83d8b |
print "1..20\n";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
eval {
|
|
Packit |
a83d8b |
$SIG{ALRM} = sub { die; };
|
|
Packit |
a83d8b |
alarm 120;
|
|
Packit |
a83d8b |
};
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
use IO::Socket::INET6;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
my $listen = IO::Socket::INET6->new(Listen => 2,
|
|
Packit |
a83d8b |
Proto => 'tcp',
|
|
Packit |
a83d8b |
# some systems seem to need as much as 10,
|
|
Packit |
a83d8b |
# so be generous with the timeout
|
|
Packit |
a83d8b |
Timeout => 15,
|
|
Packit |
a83d8b |
) or die "$@";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
print "ok 1\n";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
# Check if can fork with dynamic extensions (bug in CRT):
|
|
Packit |
a83d8b |
if ($^O eq 'os2' and
|
|
Packit |
a83d8b |
system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") {
|
|
Packit |
a83d8b |
print "ok $_ # skipped: broken fork\n" for 2..5;
|
|
Packit |
a83d8b |
exit 0;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
my $port = $listen->sockport;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
my ($pid, $sock);
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
if($pid = fork()) {
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$sock = $listen->accept() or die "accept failed: $!";
|
|
Packit |
a83d8b |
print "ok 2\n";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$sock->autoflush(1);
|
|
Packit |
a83d8b |
print $sock->getline();
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
print $sock "ok 4\n";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$sock->close;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
waitpid($pid,0);
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
print "ok 5\n";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
} elsif(defined $pid) {
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$sock = IO::Socket::INET6->new(PeerPort => $port,
|
|
Packit |
a83d8b |
Proto => 'tcp',
|
|
Packit |
a83d8b |
PeerAddr => 'localhost'
|
|
Packit |
a83d8b |
)
|
|
Packit |
a83d8b |
|| IO::Socket::INET6->new(PeerPort => $port,
|
|
Packit |
a83d8b |
Proto => 'tcp',
|
|
Packit |
a83d8b |
PeerAddr => '::1'
|
|
Packit |
a83d8b |
)
|
|
Packit |
a83d8b |
or die "$! (maybe your system does not have a localhost at all, 'localhost' or ::1)";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$sock->autoflush(1);
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
print $sock "ok 3\n";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
print $sock->getline();
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$sock->close;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
exit;
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
die;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
# Test various other ways to create INET sockets that should
|
|
Packit |
a83d8b |
# also work.
|
|
Packit |
a83d8b |
$listen = IO::Socket::INET6->new(Listen => '', Timeout => 15) or die "$@";
|
|
Packit |
a83d8b |
$port = $listen->sockport;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
if($pid = fork()) {
|
|
Packit |
a83d8b |
SERVER_LOOP:
|
|
Packit |
a83d8b |
while (1) {
|
|
Packit |
a83d8b |
last SERVER_LOOP unless $sock = $listen->accept;
|
|
Packit |
a83d8b |
while (<$sock>) {
|
|
Packit |
a83d8b |
last SERVER_LOOP if /^quit/;
|
|
Packit |
a83d8b |
last if /^done/;
|
|
Packit |
a83d8b |
print;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
$sock = undef;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
$listen->close;
|
|
Packit |
a83d8b |
} elsif (defined $pid) {
|
|
Packit |
a83d8b |
# child, try various ways to connect
|
|
Packit |
a83d8b |
$sock = IO::Socket::INET6->new("localhost:$port")
|
|
Packit |
a83d8b |
|| IO::Socket::INET6->new("[::1]:$port");
|
|
Packit |
a83d8b |
if ($sock) {
|
|
Packit |
a83d8b |
print "not " unless $sock->connected;
|
|
Packit |
a83d8b |
print "ok 6\n";
|
|
Packit |
a83d8b |
$sock->print("ok 7\n");
|
|
Packit |
a83d8b |
sleep(1);
|
|
Packit |
a83d8b |
print "ok 8\n";
|
|
Packit |
a83d8b |
$sock->print("ok 9\n");
|
|
Packit |
a83d8b |
$sock->print("done\n");
|
|
Packit |
a83d8b |
$sock->close;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
else {
|
|
Packit |
a83d8b |
print "# $@\n";
|
|
Packit |
a83d8b |
print "not ok 6\n";
|
|
Packit |
a83d8b |
print "not ok 7\n";
|
|
Packit |
a83d8b |
print "not ok 8\n";
|
|
Packit |
a83d8b |
print "not ok 9\n";
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
# some machines seem to suffer from a race condition here
|
|
Packit |
a83d8b |
sleep(2);
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$sock = IO::Socket::INET6->new("[::1]:$port");
|
|
Packit |
a83d8b |
if ($sock) {
|
|
Packit |
a83d8b |
$sock->print("ok 10\n");
|
|
Packit |
a83d8b |
$sock->print("done\n");
|
|
Packit |
a83d8b |
$sock->close;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
else {
|
|
Packit |
a83d8b |
print "# $@\n";
|
|
Packit |
a83d8b |
print "not ok 10\n";
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
# some machines seem to suffer from a race condition here
|
|
Packit |
a83d8b |
sleep(1);
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$sock = IO::Socket->new(Domain => AF_INET6,
|
|
Packit |
a83d8b |
PeerAddr => "localhost:$port")
|
|
Packit |
a83d8b |
|| IO::Socket->new(Domain => AF_INET6,
|
|
Packit |
a83d8b |
PeerAddr => "[::1]:$port");
|
|
Packit |
a83d8b |
if ($sock) {
|
|
Packit |
a83d8b |
$sock->print("ok 11\n");
|
|
Packit |
a83d8b |
$sock->print("quit\n");
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
print "not ok 11\n";
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
$sock = undef;
|
|
Packit |
a83d8b |
sleep(1);
|
|
Packit |
a83d8b |
exit;
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
die;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
# Then test UDP sockets
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
# Test the numeric address directly because "localhost" usually maps
|
|
Packit |
a83d8b |
# to an IPv4 address.
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
my $server = IO::Socket->new(
|
|
Packit |
a83d8b |
Domain => AF_INET6,
|
|
Packit |
a83d8b |
Proto => 'udp',
|
|
Packit |
a83d8b |
LocalAddr => '::1');
|
|
Packit |
a83d8b |
$port = $server->sockport;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
if ($^O eq 'mpeix') {
|
|
Packit |
a83d8b |
print("ok 12 # skipped\n")
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
if ($pid = fork()) {
|
|
Packit |
a83d8b |
my $buf;
|
|
Packit |
a83d8b |
$server->recv($buf, 100);
|
|
Packit |
a83d8b |
print $buf;
|
|
Packit |
a83d8b |
} elsif (defined($pid)) {
|
|
Packit |
a83d8b |
#child
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
# Test the numeric address directly because "localhost" usually maps
|
|
Packit |
a83d8b |
# to an IPv4 address.
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$sock = IO::Socket::INET6->new(Proto => 'udp',
|
|
Packit |
a83d8b |
Domain => AF_INET6,
|
|
Packit |
a83d8b |
PeerAddr => "[::1]:$port");
|
|
Packit |
a83d8b |
$sock->send("ok 12\n");
|
|
Packit |
a83d8b |
sleep(1);
|
|
Packit |
a83d8b |
$sock->send("ok 12\n");
|
|
Packit |
a83d8b |
exit;
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
die;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
print "not " unless $server->blocking;
|
|
Packit |
a83d8b |
print "ok 13\n";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
if ( $^O eq 'qnx' ) {
|
|
Packit |
a83d8b |
# QNX library bug: Can set non-blocking on socket, but
|
|
Packit |
a83d8b |
# cannot return that status.
|
|
Packit |
a83d8b |
print "ok 14 # skipped\n";
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
$server->blocking(0);
|
|
Packit |
a83d8b |
print "not " if $server->blocking;
|
|
Packit |
a83d8b |
print "ok 14\n";
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
### TEST 15
|
|
Packit |
a83d8b |
### Set up some data to be transfered between the server and
|
|
Packit |
a83d8b |
### the client. We'll use own source code ...
|
|
Packit |
a83d8b |
#
|
|
Packit |
a83d8b |
my @data;
|
|
Packit |
a83d8b |
if( !open( SRC, "< $0")) {
|
|
Packit |
a83d8b |
print "not ok 15 - $!";
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
@data = <SRC>;
|
|
Packit |
a83d8b |
close( SRC);
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
print "ok 15\n";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
### TEST 16
|
|
Packit |
a83d8b |
### Start the server
|
|
Packit |
a83d8b |
#
|
|
Packit |
a83d8b |
$listen = IO::Socket::INET6->new( Listen => 2, Proto => 'tcp', Timeout => 15) ||
|
|
Packit |
a83d8b |
print "not ";
|
|
Packit |
a83d8b |
print "ok 16\n";
|
|
Packit |
a83d8b |
die if( !defined( $listen));
|
|
Packit |
a83d8b |
my $serverport = $listen->sockport;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
my $server_pid = fork();
|
|
Packit |
a83d8b |
if( $server_pid) {
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
### TEST 17 Client/Server establishment
|
|
Packit |
a83d8b |
#
|
|
Packit |
a83d8b |
print "ok 17\n";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
### TEST 18
|
|
Packit |
a83d8b |
### Get data from the server using a single stream
|
|
Packit |
a83d8b |
#
|
|
Packit |
a83d8b |
$sock = IO::Socket::INET6->new("localhost:$serverport")
|
|
Packit |
a83d8b |
|| IO::Socket::INET6->new("[::1]:$serverport");
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
if ($sock) {
|
|
Packit |
a83d8b |
$sock->print("send\n");
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
my @array = ();
|
|
Packit |
a83d8b |
while( <$sock>) {
|
|
Packit |
a83d8b |
push( @array, $_);
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$sock->print("done\n");
|
|
Packit |
a83d8b |
$sock->close;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
print "not " if( @array != @data);
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
print "not ";
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
print "ok 18\n";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
### TEST 19
|
|
Packit |
a83d8b |
### Get data from the server using a stream, which is
|
|
Packit |
a83d8b |
### interrupted by eof calls.
|
|
Packit |
a83d8b |
### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof
|
|
Packit |
a83d8b |
### did an getc followed by an ungetc in order to check for the streams
|
|
Packit |
a83d8b |
### end. getc(3) got replaced by the SOCKS funktion, which ended up in
|
|
Packit |
a83d8b |
### a recv(2) call on the socket, while ungetc(3) put back a character
|
|
Packit |
a83d8b |
### to an IO buffer, which never again was read.
|
|
Packit |
a83d8b |
#
|
|
Packit |
a83d8b |
if ($^O eq 'mpeix') {
|
|
Packit |
a83d8b |
print "ok 19 # skipped: broken on MPE/iX\n";
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
$sock = IO::Socket::INET6->new("localhost:$serverport")
|
|
Packit |
a83d8b |
|| IO::Socket::INET6->new("[::1]:$serverport");
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
if ($sock) {
|
|
Packit |
a83d8b |
$sock->print("send\n");
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
my @array = ();
|
|
Packit |
a83d8b |
while( !eof( $sock ) ){
|
|
Packit |
a83d8b |
while( <$sock>) {
|
|
Packit |
a83d8b |
push( @array, $_);
|
|
Packit |
a83d8b |
last;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
$sock->print("done\n");
|
|
Packit |
a83d8b |
$sock->close;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
print "not " if( @array != @data);
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
print "not ";
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
print "ok 19\n";
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
### TEST 20
|
|
Packit |
a83d8b |
### Stop the server
|
|
Packit |
a83d8b |
#
|
|
Packit |
a83d8b |
$sock = IO::Socket::INET6->new("localhost:$serverport")
|
|
Packit |
a83d8b |
|| IO::Socket::INET6->new("[::1]:$serverport");
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
if ($sock) {
|
|
Packit |
a83d8b |
$sock->print("done\n");
|
|
Packit |
a83d8b |
$sock->close;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
print "not " if( 1 != kill 0, $server_pid);
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
print "not ";
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
print "ok 20\n";
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
} elsif( defined( $server_pid)) {
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
### Child
|
|
Packit |
a83d8b |
#
|
|
Packit |
a83d8b |
SERVER_LOOP: while (1) {
|
|
Packit |
a83d8b |
last SERVER_LOOP unless $sock = $listen->accept;
|
|
Packit |
a83d8b |
while (<$sock>) {
|
|
Packit |
a83d8b |
last SERVER_LOOP if /^quit/;
|
|
Packit |
a83d8b |
last if /^done/;
|
|
Packit |
a83d8b |
if( /^send/) {
|
|
Packit |
a83d8b |
print $sock @data;
|
|
Packit |
a83d8b |
last;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
print;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
$sock = undef;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
$listen->close;
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
} else {
|
|
Packit |
a83d8b |
|
|
Packit |
a83d8b |
### Fork failed
|
|
Packit |
a83d8b |
#
|
|
Packit |
a83d8b |
print "not ok 17\n";
|
|
Packit |
a83d8b |
die;
|
|
Packit |
a83d8b |
}
|
|
Packit |
a83d8b |
|