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