[p5sagit/p5-mst-13.2.git] / ext / IO / t / io_sock.t

#!./perl -w

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
}

use Config;

BEGIN {
    if (-d "lib" && -f "TEST") {
	my $reason;
	if (! $Config{'d_fork'}) {
	    $reason = 'no fork';
	}
	elsif ($Config{'extensions'} !~ /\bSocket\b/) {
	    $reason = 'Socket extension unavailable';
	}
	elsif ($Config{'extensions'} !~ /\bIO\b/) {
	    $reason = 'IO extension unavailable';
	}
	if ($reason) {
	    print "1..0 # Skip: $reason\n";
	    exit 0;
        }
    }
}

my $has_perlio = find PerlIO::Layer 'perlio';

$| = 1;
print "1..26\n";

eval {
    $SIG{ALRM} = sub { die; };
    alarm 120;
};

use IO::Socket;

$listen = IO::Socket::INET->new(Listen => 2,
				Proto => 'tcp',
				# some systems seem to need as much as 10,
				# so be generous with the timeout
				Timeout => 15,
			       ) or die "$!";

print "ok 1\n";

# Check if can fork with dynamic extensions (bug in CRT):
if ($^O eq 'os2' and
    system "$^X -I../lib -MOpcode -e 'defined fork or die'  > /dev/null 2>&1") {
    print "ok $_ # skipped: broken fork\n" for 2..5;
    exit 0;
}

$port = $listen->sockport;

if($pid = fork()) {

    $sock = $listen->accept() or die "accept failed: $!";
    print "ok 2\n";

    $sock->autoflush(1);
    print $sock->getline();

    print $sock "ok 4\n";

    $sock->close;

    waitpid($pid,0);

    print "ok 5\n";

} elsif(defined $pid) {

    $sock = IO::Socket::INET->new(PeerPort => $port,
				  Proto => 'tcp',
				  PeerAddr => 'localhost'
				 )
         || IO::Socket::INET->new(PeerPort => $port,
				  Proto => 'tcp',
				  PeerAddr => '127.0.0.1'
				 )
	or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";

    $sock->autoflush(1);

    print $sock "ok 3\n";

    print $sock->getline();

    $sock->close;

    exit;
} else {
 die;
}

# Test various other ways to create INET sockets that should
# also work.
$listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!";
$port = $listen->sockport;

if($pid = fork()) {
  SERVER_LOOP:
    while (1) {
       last SERVER_LOOP unless $sock = $listen->accept;
       while (<$sock>) {
           last SERVER_LOOP if /^quit/;
           last if /^done/;
           print;
       }
       $sock = undef;
    }
    $listen->close;
} elsif (defined $pid) {
    # child, try various ways to connect
    $sock = IO::Socket::INET->new("localhost:$port")
         || IO::Socket::INET->new("127.0.0.1:$port");
    if ($sock) {
	print "not " unless $sock->connected;
	print "ok 6\n";
       $sock->print("ok 7\n");
       sleep(1);
       print "ok 8\n";
       $sock->print("ok 9\n");
       $sock->print("done\n");
       $sock->close;
    }
    else {
	print "# $@\n";
	print "not ok 6\n";
	print "not ok 7\n";
	print "not ok 8\n";
	print "not ok 9\n";
    }

    # some machines seem to suffer from a race condition here
    sleep(2);

    $sock = IO::Socket::INET->new("127.0.0.1:$port");
    if ($sock) {
       $sock->print("ok 10\n");
       $sock->print("done\n");
       $sock->close;
    }
    else {
	print "# $@\n";
	print "not ok 10\n";
    }

    # some machines seem to suffer from a race condition here
    sleep(1);

    $sock = IO::Socket->new(Domain => AF_INET,
                            PeerAddr => "localhost:$port")
         || IO::Socket->new(Domain => AF_INET,
                            PeerAddr => "127.0.0.1:$port");
    if ($sock) {
       $sock->print("ok 11\n");
       $sock->print("quit\n");
    } else {
       print "not ok 11\n";
    }
    $sock = undef;
    sleep(1);
    exit;
} else {
    die;
}

# Then test UDP sockets
$server = IO::Socket->new(Domain => AF_INET,
                          Proto  => 'udp',
                          LocalAddr => 'localhost')
       || IO::Socket->new(Domain => AF_INET,
                          Proto  => 'udp',
                          LocalAddr => '127.0.0.1');
$port = $server->sockport;

if ($pid = fork()) {
    my $buf;
    $server->recv($buf, 100);
    print $buf;
} elsif (defined($pid)) {
    #child
    $sock = IO::Socket::INET->new(Proto => 'udp',
                                  PeerAddr => "localhost:$port")
         || IO::Socket::INET->new(Proto => 'udp',
                                  PeerAddr => "127.0.0.1:$port");
    $sock->send("ok 12\n");
    sleep(1);
    $sock->send("ok 12\n");  # send another one to be sure
    exit;
} else {
    die;
}

print "not " unless $server->blocking;
print "ok 13\n";

if ( $^O eq 'qnx' ) {
  # QNX4 library bug: Can set non-blocking on socket, but
  # cannot return that status.
  print "ok 14 # skipped on QNX4\n";
} else {
  $server->blocking(0);
  print "not " if $server->blocking;
  print "ok 14\n";
}

### TEST 15
### Set up some data to be transfered between the server and
### the client. We'll use own source code ...
#
local @data;
if( !open( SRC, "< $0")) {
    print "not ok 15 - $!\n";
} else {
    @data = <SRC>;
    close(SRC);
    print "ok 15\n";
}

### TEST 16
### Start the server
#
my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) ||
    print "not ";
print "ok 16\n";
die if( !defined( $listen));
my $serverport = $listen->sockport;
my $server_pid = fork();
if( $server_pid) {

    ### TEST 17 Client/Server establishment
    #
    print "ok 17\n";

    ### TEST 18
    ### Get data from the server using a single stream
    #
    $sock = IO::Socket::INET->new("localhost:$serverport")
         || IO::Socket::INET->new("127.0.0.1:$serverport");

    if ($sock) {
	$sock->print("send\n");

	my @array = ();
	while( <$sock>) {
	    push( @array, $_);
	}

	$sock->print("done\n");
	$sock->close;

	print "not " if( @array != @data);
    } else {
	print "not ";
    }
    print "ok 18\n";

    ### TEST 21
    ### Get data from the server using a stream, which is
    ### interrupted by eof calls.
    ### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof
    ### did an getc followed by an ungetc in order to check for the streams
    ### end. getc(3) got replaced by the SOCKS funktion, which ended up in
    ### a recv(2) call on the socket, while ungetc(3) put back a character
    ### to an IO buffer, which never again was read.
    #
    ### TESTS 19,20,21,22
    ### Try to ping-pong some Unicode.
    #
    $sock = IO::Socket::INET->new("localhost:$serverport")
         || IO::Socket::INET->new("127.0.0.1:$serverport");

    if ($has_perlio) {
	print binmode($sock, ":utf8") ? "ok 19\n" : "not ok 19\n";
    } else {
	print "ok 19 - Skip: no perlio\n";
    }

    if ($sock) {

	if ($has_perlio) {
	    $sock->print("ping \x{100}\n");
	    chomp(my $pong = scalar <$sock>);
	    print $pong =~ /^pong (.+)$/ && $1 eq "\x{100}" ?
		"ok 20\n" : "not ok 20\n";

	    $sock->print("ord \x{100}\n");
	    chomp(my $ord = scalar <$sock>);
	    print $ord == 0x100 ?
		"ok 21\n" : "not ok 21\n";

	    $sock->print("chr 0x100\n");
	    chomp(my $chr = scalar <$sock>);
	    print $chr eq "\x{100}" ?
		"ok 22\n" : "not ok 22\n";
	} else {
	    print "ok $_ - Skip: no perlio\n" for 20..22;
	}

	$sock->print("send\n");

	my @array = ();
	while( !eof( $sock ) ){
	    while( <$sock>) {
		push( @array, $_);
		last;
	    }
	}

	$sock->print("done\n");
	$sock->close;

	print "not " if( @array != @data);
    } else {
	print "not ";
    }
    print "ok 23\n";

    ### TEST 24
    ### Stop the server
    #
    $sock = IO::Socket::INET->new("localhost:$serverport")
         || IO::Socket::INET->new("127.0.0.1:$serverport");

    if ($sock) {
	$sock->print("done\n");
	$sock->close;

	print "not " if( 1 != kill 0, $server_pid);
    } else {
	print "not ";
    }
    print "ok 24\n";

} elsif (defined($server_pid)) {
   
    ### Child
    #
    SERVER_LOOP: while (1) {
	last SERVER_LOOP unless $sock = $listen->accept;
	# Do not print ok/not ok for this binmode() since there's
	# a race condition with our client, just die if we fail.
	if ($has_perlio) { binmode($sock, ":utf8") or die }
	while (<$sock>) {
	    last SERVER_LOOP if /^quit/;
	    last if /^done/;
	    if (/^ping (.+)/) {
		print $sock "pong $1\n";
		next;
	    }
	    if (/^ord (.+)/) {
		print $sock ord($1), "\n";
		next;
	    }
	    if (/^chr (.+)/) {
		print $sock chr(hex($1)), "\n";
		next;
	    }
	    if (/^send/) {
		print $sock @data;
		last;
	    }
	    print;
	}
	$sock = undef;
    }
    $listen->close;
    exit 0;

} else {

    ### Fork failed
    #
    print "not ok 17\n";
    die;
}

# test Blocking option in constructor

$sock = IO::Socket::INET->new(Blocking => 0)
    or print "not ";
print "ok 25\n";

if ( $^O eq 'qnx' ) {
  print "ok 26 # skipped on QNX4\n";
  # QNX4 library bug: Can set non-blocking on socket, but
  # cannot return that status.
} else {
  my $status = $sock->blocking;
  print "not " unless defined $status && !$status;
  print "ok 26\n";
}
Commit	Line	Data
ce4f4a1c	1	#!./perl -w
61f2b451	2
61f2b451	3	BEGIN {
7a4c00b4	4	unless(grep /blib/, @INC) {
7a4c00b4	5	chdir 't' if -d 't';
20822f61	6	@INC = '../lib';
7a4c00b4	7	}
	8	}
	9
	10	use Config;
	11
	12	BEGIN {
774d564b	13	if (-d "lib" && -f "TEST") {
45c0de28	14	my $reason;
	15	if (! $Config{'d_fork'}) {
	16	$reason = 'no fork';
	17	}
	18	elsif ($Config{'extensions'} !~ /\bSocket\b/) {
	19	$reason = 'Socket extension unavailable';
	20	}
	21	elsif ($Config{'extensions'} !~ /\bIO\b/) {
	22	$reason = 'IO extension unavailable';
	23	}
45c0de28	24	if ($reason) {
45c0de28	25	print "1..0 # Skip: $reason\n";
7a4c00b4	26	exit 0;
7a4c00b4	27	}
61f2b451	28	}
	29	}
	30
fcdfa64f	31	my $has_perlio = find PerlIO::Layer 'perlio';
fcdfa64f	32
61f2b451	33	$\| = 1;
0c28a436	34	print "1..26\n";
61f2b451	35
560d348b	36	eval {
	37	$SIG{ALRM} = sub { die; };
	38	alarm 120;
	39	};
	40
61f2b451	41	use IO::Socket;
61f2b451	42
7a4c00b4	43	$listen = IO::Socket::INET->new(Listen => 2,
7a4c00b4	44	Proto => 'tcp',
862b0ad8	45	# some systems seem to need as much as 10,
	46	# so be generous with the timeout
	47	Timeout => 15,
7a4c00b4	48	) or die "$!";
61f2b451	49
7a4c00b4	50	print "ok 1\n";
61f2b451	51
a245ea2d	52	# Check if can fork with dynamic extensions (bug in CRT):
	53	if ($^O eq 'os2' and
	54	system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") {
	55	print "ok $_ # skipped: broken fork\n" for 2..5;
	56	exit 0;
	57	}
	58
7a4c00b4	59	$port = $listen->sockport;
61f2b451	60
7a4c00b4	61	if($pid = fork()) {
61f2b451	62
e197ebb9	63	$sock = $listen->accept() or die "accept failed: $!";
61f2b451	64	print "ok 2\n";
	65
	66	$sock->autoflush(1);
	67	print $sock->getline();
	68
	69	print $sock "ok 4\n";
	70
	71	$sock->close;
	72
	73	waitpid($pid,0);
	74
	75	print "ok 5\n";
61f2b451	76
7a4c00b4	77	} elsif(defined $pid) {
61f2b451	78
	79	$sock = IO::Socket::INET->new(PeerPort => $port,
	80	Proto => 'tcp',
	81	PeerAddr => 'localhost'
9b599b2a	82	)
6e806fe3	83	\|\| IO::Socket::INET->new(PeerPort => $port,
	84	Proto => 'tcp',
	85	PeerAddr => '127.0.0.1'
	86	)
	87	or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";
61f2b451	88
61f2b451	89	$sock->autoflush(1);
7a4c00b4	90
61f2b451	91	print $sock "ok 3\n";
7a4c00b4	92
61f2b451	93	print $sock->getline();
7a4c00b4	94
61f2b451	95	$sock->close;
7a4c00b4	96
61f2b451	97	exit;
	98	} else {
	99	die;
	100	}
	101
cf7fe8a2	102	# Test various other ways to create INET sockets that should
cf7fe8a2	103	# also work.
862b0ad8	104	$listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!";
cf7fe8a2	105	$port = $listen->sockport;
61f2b451	106
cf7fe8a2	107	if($pid = fork()) {
	108	SERVER_LOOP:
	109	while (1) {
	110	last SERVER_LOOP unless $sock = $listen->accept;
	111	while (<$sock>) {
	112	last SERVER_LOOP if /^quit/;
	113	last if /^done/;
	114	print;
	115	}
	116	$sock = undef;
	117	}
	118	$listen->close;
	119	} elsif (defined $pid) {
	120	# child, try various ways to connect
6e806fe3	121	$sock = IO::Socket::INET->new("localhost:$port")
6e806fe3	122	\|\| IO::Socket::INET->new("127.0.0.1:$port");
cf7fe8a2	123	if ($sock) {
	124	print "not " unless $sock->connected;
	125	print "ok 6\n";
	126	$sock->print("ok 7\n");
	127	sleep(1);
	128	print "ok 8\n";
	129	$sock->print("ok 9\n");
	130	$sock->print("done\n");
	131	$sock->close;
	132	}
	133	else {
	134	print "# $@\n";
	135	print "not ok 6\n";
	136	print "not ok 7\n";
	137	print "not ok 8\n";
	138	print "not ok 9\n";
	139	}
	140
	141	# some machines seem to suffer from a race condition here
d6a255e6	142	sleep(2);
cf7fe8a2	143
	144	$sock = IO::Socket::INET->new("127.0.0.1:$port");
	145	if ($sock) {
	146	$sock->print("ok 10\n");
	147	$sock->print("done\n");
	148	$sock->close;
	149	}
	150	else {
	151	print "# $@\n";
	152	print "not ok 10\n";
	153	}
61f2b451	154
cf7fe8a2	155	# some machines seem to suffer from a race condition here
e3e876cf	156	sleep(1);
61f2b451	157
cf7fe8a2	158	$sock = IO::Socket->new(Domain => AF_INET,
6e806fe3	159	PeerAddr => "localhost:$port")
	160	\|\| IO::Socket->new(Domain => AF_INET,
	161	PeerAddr => "127.0.0.1:$port");
cf7fe8a2	162	if ($sock) {
	163	$sock->print("ok 11\n");
	164	$sock->print("quit\n");
9d44748a	165	} else {
9d44748a	166	print "not ok 11\n";
cf7fe8a2	167	}
	168	$sock = undef;
	169	sleep(1);
	170	exit;
	171	} else {
	172	die;
	173	}
	174
	175	# Then test UDP sockets
	176	$server = IO::Socket->new(Domain => AF_INET,
	177	Proto => 'udp',
6e806fe3	178	LocalAddr => 'localhost')
	179	\|\| IO::Socket->new(Domain => AF_INET,
	180	Proto => 'udp',
	181	LocalAddr => '127.0.0.1');
cf7fe8a2	182	$port = $server->sockport;
cf7fe8a2	183
b606c525	184	if ($pid = fork()) {
	185	my $buf;
	186	$server->recv($buf, 100);
	187	print $buf;
	188	} elsif (defined($pid)) {
	189	#child
	190	$sock = IO::Socket::INET->new(Proto => 'udp',
	191	PeerAddr => "localhost:$port")
	192	\|\| IO::Socket::INET->new(Proto => 'udp',
	193	PeerAddr => "127.0.0.1:$port");
	194	$sock->send("ok 12\n");
	195	sleep(1);
	196	$sock->send("ok 12\n"); # send another one to be sure
	197	exit;
cf7fe8a2	198	} else {
b606c525	199	die;
cf7fe8a2	200	}
61f2b451	201
cf7fe8a2	202	print "not " unless $server->blocking;
cf7fe8a2	203	print "ok 13\n";
61f2b451	204
39990a16	205	if ( $^O eq 'qnx' ) {
6dea6691	206	# QNX4 library bug: Can set non-blocking on socket, but
39990a16	207	# cannot return that status.
6dea6691	208	print "ok 14 # skipped on QNX4\n";
39990a16	209	} else {
	210	$server->blocking(0);
	211	print "not " if $server->blocking;
	212	print "ok 14\n";
	213	}
cf829ab0	214
	215	### TEST 15
	216	### Set up some data to be transfered between the server and
	217	### the client. We'll use own source code ...
	218	#
	219	local @data;
	220	if( !open( SRC, "< $0")) {
3c83a670	221	print "not ok 15 - $!\n";
cf829ab0	222	} else {
cf829ab0	223	@data = <SRC>;
fcdfa64f	224	close(SRC);
3c83a670	225	print "ok 15\n";
cf829ab0	226	}
cf829ab0	227
	228	### TEST 16
	229	### Start the server
	230	#
	231	my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) \|\|
	232	print "not ";
	233	print "ok 16\n";
	234	die if( !defined( $listen));
	235	my $serverport = $listen->sockport;
cf829ab0	236	my $server_pid = fork();
	237	if( $server_pid) {
	238
	239	### TEST 17 Client/Server establishment
	240	#
	241	print "ok 17\n";
	242
	243	### TEST 18
	244	### Get data from the server using a single stream
	245	#
	246	$sock = IO::Socket::INET->new("localhost:$serverport")
	247	\|\| IO::Socket::INET->new("127.0.0.1:$serverport");
	248
	249	if ($sock) {
	250	$sock->print("send\n");
	251
	252	my @array = ();
	253	while( <$sock>) {
	254	push( @array, $_);
	255	}
	256
	257	$sock->print("done\n");
	258	$sock->close;
	259
	260	print "not " if( @array != @data);
	261	} else {
	262	print "not ";
	263	}
	264	print "ok 18\n";
	265
ce4f4a1c	266	### TEST 21
cf829ab0	267	### Get data from the server using a stream, which is
	268	### interrupted by eof calls.
	269	### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof
	270	### did an getc followed by an ungetc in order to check for the streams
	271	### end. getc(3) got replaced by the SOCKS funktion, which ended up in
	272	### a recv(2) call on the socket, while ungetc(3) put back a character
	273	### to an IO buffer, which never again was read.
	274	#
0c28a436	275	### TESTS 19,20,21,22
0c28a436	276	### Try to ping-pong some Unicode.
fcdfa64f	277	#
cf829ab0	278	$sock = IO::Socket::INET->new("localhost:$serverport")
	279	\|\| IO::Socket::INET->new("127.0.0.1:$serverport");
	280
ce4f4a1c	281	if ($has_perlio) {
	282	print binmode($sock, ":utf8") ? "ok 19\n" : "not ok 19\n";
	283	} else {
	284	print "ok 19 - Skip: no perlio\n";
	285	}
fcdfa64f	286
cf829ab0	287	if ($sock) {
fcdfa64f	288
	289	if ($has_perlio) {
	290	$sock->print("ping \x{100}\n");
	291	chomp(my $pong = scalar <$sock>);
	292	print $pong =~ /^pong (.+)$/ && $1 eq "\x{100}" ?
ce4f4a1c	293	"ok 20\n" : "not ok 20\n";
0c28a436	294
	295	$sock->print("ord \x{100}\n");
	296	chomp(my $ord = scalar <$sock>);
	297	print $ord == 0x100 ?
	298	"ok 21\n" : "not ok 21\n";
	299
	300	$sock->print("chr 0x100\n");
	301	chomp(my $chr = scalar <$sock>);
	302	print $chr eq "\x{100}" ?
	303	"ok 22\n" : "not ok 22\n";
fcdfa64f	304	} else {
0c28a436	305	print "ok $_ - Skip: no perlio\n" for 20..22;
fcdfa64f	306	}
fcdfa64f	307
cf829ab0	308	$sock->print("send\n");
	309
	310	my @array = ();
	311	while( !eof( $sock ) ){
	312	while( <$sock>) {
	313	push( @array, $_);
	314	last;
	315	}
	316	}
	317
	318	$sock->print("done\n");
	319	$sock->close;
	320
	321	print "not " if( @array != @data);
	322	} else {
	323	print "not ";
	324	}
0c28a436	325	print "ok 23\n";
cf829ab0	326
0c28a436	327	### TEST 24
cf829ab0	328	### Stop the server
	329	#
	330	$sock = IO::Socket::INET->new("localhost:$serverport")
	331	\|\| IO::Socket::INET->new("127.0.0.1:$serverport");
	332
	333	if ($sock) {
	334	$sock->print("done\n");
	335	$sock->close;
	336
	337	print "not " if( 1 != kill 0, $server_pid);
	338	} else {
	339	print "not ";
	340	}
0c28a436	341	print "ok 24\n";
cf829ab0	342
fcdfa64f	343	} elsif (defined($server_pid)) {
cf829ab0	344
	345	### Child
	346	#
	347	SERVER_LOOP: while (1) {
	348	last SERVER_LOOP unless $sock = $listen->accept;
0c28a436	349	# Do not print ok/not ok for this binmode() since there's
0c28a436	350	# a race condition with our client, just die if we fail.
29929b39	351	if ($has_perlio) { binmode($sock, ":utf8") or die }
cf829ab0	352	while (<$sock>) {
	353	last SERVER_LOOP if /^quit/;
	354	last if /^done/;
fcdfa64f	355	if (/^ping (.+)/) {
	356	print $sock "pong $1\n";
	357	next;
	358	}
0c28a436	359	if (/^ord (.+)/) {
	360	print $sock ord($1), "\n";
	361	next;
	362	}
	363	if (/^chr (.+)/) {
	364	print $sock chr(hex($1)), "\n";
	365	next;
	366	}
fcdfa64f	367	if (/^send/) {
cf829ab0	368	print $sock @data;
	369	last;
	370	}
	371	print;
	372	}
	373	$sock = undef;
	374	}
	375	$listen->close;
3c83a670	376	exit 0;
cf829ab0	377
	378	} else {
	379
	380	### Fork failed
	381	#
	382	print "not ok 17\n";
	383	die;
	384	}
	385
3c83a670	386	# test Blocking option in constructor
	387
	388	$sock = IO::Socket::INET->new(Blocking => 0)
	389	or print "not ";
0c28a436	390	print "ok 25\n";
3c83a670	391
6dea6691	392	if ( $^O eq 'qnx' ) {
0c28a436	393	print "ok 26 # skipped on QNX4\n";
6dea6691	394	# QNX4 library bug: Can set non-blocking on socket, but
	395	# cannot return that status.
	396	} else {
	397	my $status = $sock->blocking;
	398	print "not " unless defined $status && !$status;
0c28a436	399	print "ok 26\n";
6dea6691	400	}