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

#!./perl

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..23\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 ($^O eq 'mpeix') {
    print("ok 12 # skipped\n")
} else {
    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 19
    ### 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.
    #
    ### TEST 20
    ### Try to ping-pong a Unicode character.
    #
    if ($^O eq 'mpeix') {
	print "ok 19 # skipped: broken on MPE/iX\n";
    } else {
    $sock = IO::Socket::INET->new("localhost:$serverport")
         || IO::Socket::INET->new("127.0.0.1:$serverport");

    binmode($sock, ":utf8") if $has_perlio;

    if ($sock) {

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

	$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 20\n";
    }

    ### TEST 21
    ### 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 21\n";

} elsif (defined($server_pid)) {
   
    ### Child
    #
    SERVER_LOOP: while (1) {
	last SERVER_LOOP unless $sock = $listen->accept;
	while (<$sock>) {
	    last SERVER_LOOP if /^quit/;
	    last if /^done/;
	    if (/^ping (.+)/) {
		print $sock "pong $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 22\n";

if ( $^O eq 'qnx' ) {
  print "ok 23 # 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 23\n";
}
Commit	Line	Data
61f2b451	1	#!./perl
	2
	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;
fcdfa64f	34	print "1..23\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
0994c4d0	184	if ($^O eq 'mpeix') {
0994c4d0	185	print("ok 12 # skipped\n")
cf7fe8a2	186	} else {
0994c4d0	187	if ($pid = fork()) {
	188	my $buf;
	189	$server->recv($buf, 100);
	190	print $buf;
	191	} elsif (defined($pid)) {
	192	#child
	193	$sock = IO::Socket::INET->new(Proto => 'udp',
6e806fe3	194	PeerAddr => "localhost:$port")
	195	\|\| IO::Socket::INET->new(Proto => 'udp',
	196	PeerAddr => "127.0.0.1:$port");
0994c4d0	197	$sock->send("ok 12\n");
	198	sleep(1);
	199	$sock->send("ok 12\n"); # send another one to be sure
	200	exit;
	201	} else {
	202	die;
	203	}
cf7fe8a2	204	}
61f2b451	205
cf7fe8a2	206	print "not " unless $server->blocking;
cf7fe8a2	207	print "ok 13\n";
61f2b451	208
39990a16	209	if ( $^O eq 'qnx' ) {
6dea6691	210	# QNX4 library bug: Can set non-blocking on socket, but
39990a16	211	# cannot return that status.
6dea6691	212	print "ok 14 # skipped on QNX4\n";
39990a16	213	} else {
	214	$server->blocking(0);
	215	print "not " if $server->blocking;
	216	print "ok 14\n";
	217	}
cf829ab0	218
	219	### TEST 15
	220	### Set up some data to be transfered between the server and
	221	### the client. We'll use own source code ...
	222	#
	223	local @data;
	224	if( !open( SRC, "< $0")) {
3c83a670	225	print "not ok 15 - $!\n";
cf829ab0	226	} else {
cf829ab0	227	@data = <SRC>;
fcdfa64f	228	close(SRC);
3c83a670	229	print "ok 15\n";
cf829ab0	230	}
cf829ab0	231
	232	### TEST 16
	233	### Start the server
	234	#
	235	my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) \|\|
	236	print "not ";
	237	print "ok 16\n";
	238	die if( !defined( $listen));
	239	my $serverport = $listen->sockport;
cf829ab0	240	my $server_pid = fork();
	241	if( $server_pid) {
	242
	243	### TEST 17 Client/Server establishment
	244	#
	245	print "ok 17\n";
	246
	247	### TEST 18
	248	### Get data from the server using a single stream
	249	#
	250	$sock = IO::Socket::INET->new("localhost:$serverport")
	251	\|\| IO::Socket::INET->new("127.0.0.1:$serverport");
	252
	253	if ($sock) {
	254	$sock->print("send\n");
	255
	256	my @array = ();
	257	while( <$sock>) {
	258	push( @array, $_);
	259	}
	260
	261	$sock->print("done\n");
	262	$sock->close;
	263
	264	print "not " if( @array != @data);
	265	} else {
	266	print "not ";
	267	}
	268	print "ok 18\n";
	269
	270	### TEST 19
	271	### Get data from the server using a stream, which is
	272	### interrupted by eof calls.
	273	### On perl-5.7.0@7673 this failed in a SOCKS environment, because eof
	274	### did an getc followed by an ungetc in order to check for the streams
	275	### end. getc(3) got replaced by the SOCKS funktion, which ended up in
	276	### a recv(2) call on the socket, while ungetc(3) put back a character
	277	### to an IO buffer, which never again was read.
	278	#
fcdfa64f	279	### TEST 20
	280	### Try to ping-pong a Unicode character.
	281	#
b62e3068	282	if ($^O eq 'mpeix') {
	283	print "ok 19 # skipped: broken on MPE/iX\n";
	284	} else {
cf829ab0	285	$sock = IO::Socket::INET->new("localhost:$serverport")
	286	\|\| IO::Socket::INET->new("127.0.0.1:$serverport");
	287
fcdfa64f	288	binmode($sock, ":utf8") if $has_perlio;
fcdfa64f	289
cf829ab0	290	if ($sock) {
fcdfa64f	291
	292	if ($has_perlio) {
	293	$sock->print("ping \x{100}\n");
	294	chomp(my $pong = scalar <$sock>);
	295	print $pong =~ /^pong (.+)$/ && $1 eq "\x{100}" ?
	296	"ok 19\n" : "not ok 19\n";
	297	} else {
	298	print "ok 19 - Skip: no perlio\n";
	299	}
	300
cf829ab0	301	$sock->print("send\n");
	302
	303	my @array = ();
	304	while( !eof( $sock ) ){
	305	while( <$sock>) {
	306	push( @array, $_);
	307	last;
	308	}
	309	}
	310
	311	$sock->print("done\n");
	312	$sock->close;
	313
	314	print "not " if( @array != @data);
	315	} else {
	316	print "not ";
	317	}
fcdfa64f	318	print "ok 20\n";
b62e3068	319	}
cf829ab0	320
fcdfa64f	321	### TEST 21
cf829ab0	322	### Stop the server
	323	#
	324	$sock = IO::Socket::INET->new("localhost:$serverport")
	325	\|\| IO::Socket::INET->new("127.0.0.1:$serverport");
	326
	327	if ($sock) {
	328	$sock->print("done\n");
	329	$sock->close;
	330
	331	print "not " if( 1 != kill 0, $server_pid);
	332	} else {
	333	print "not ";
	334	}
fcdfa64f	335	print "ok 21\n";
cf829ab0	336
fcdfa64f	337	} elsif (defined($server_pid)) {
cf829ab0	338
	339	### Child
	340	#
	341	SERVER_LOOP: while (1) {
	342	last SERVER_LOOP unless $sock = $listen->accept;
	343	while (<$sock>) {
	344	last SERVER_LOOP if /^quit/;
	345	last if /^done/;
fcdfa64f	346	if (/^ping (.+)/) {
	347	print $sock "pong $1\n";
	348	next;
	349	}
	350	if (/^send/) {
cf829ab0	351	print $sock @data;
	352	last;
	353	}
	354	print;
	355	}
	356	$sock = undef;
	357	}
	358	$listen->close;
3c83a670	359	exit 0;
cf829ab0	360
	361	} else {
	362
	363	### Fork failed
	364	#
	365	print "not ok 17\n";
	366	die;
	367	}
	368
3c83a670	369	# test Blocking option in constructor
	370
	371	$sock = IO::Socket::INET->new(Blocking => 0)
	372	or print "not ";
fcdfa64f	373	print "ok 22\n";
3c83a670	374
6dea6691	375	if ( $^O eq 'qnx' ) {
fcdfa64f	376	print "ok 23 # skipped on QNX4\n";
6dea6691	377	# QNX4 library bug: Can set non-blocking on socket, but
	378	# cannot return that status.
	379	} else {
	380	my $status = $sock->blocking;
	381	print "not " unless defined $status && !$status;
fcdfa64f	382	print "ok 23\n";
6dea6691	383	}