16fb12b70Safresh1#!perl 26fb12b70Safresh1 36fb12b70Safresh1# sanity tests for socket functions 46fb12b70Safresh1 56fb12b70Safresh1BEGIN { 66fb12b70Safresh1 chdir 't' if -d 't'; 76fb12b70Safresh1 86fb12b70Safresh1 require "./test.pl"; 99f11ffb7Safresh1 set_up_inc( '../lib' ) if -d '../lib' && -d '../ext'; 10*3d61058aSafresh1 require Config; Config->import; 116fb12b70Safresh1 126fb12b70Safresh1 skip_all_if_miniperl(); 136fb12b70Safresh1 for my $needed (qw(d_socket d_getpbyname)) { 146fb12b70Safresh1 if ($Config{$needed} ne 'define') { 156fb12b70Safresh1 skip_all("-- \$Config{$needed} undefined"); 166fb12b70Safresh1 } 176fb12b70Safresh1 } 186fb12b70Safresh1 unless ($Config{extensions} =~ /\bSocket\b/) { 196fb12b70Safresh1 skip_all('-- Socket not available'); 206fb12b70Safresh1 } 216fb12b70Safresh1} 226fb12b70Safresh1 236fb12b70Safresh1use strict; 246fb12b70Safresh1use Socket; 256fb12b70Safresh1 269f11ffb7Safresh1our $TODO; 279f11ffb7Safresh1 286fb12b70Safresh1$| = 1; # ensure test output is synchronous so processes don't conflict 296fb12b70Safresh1 306fb12b70Safresh1my $tcp = getprotobyname('tcp') 316fb12b70Safresh1 or skip_all("no tcp protocol available ($!)"); 326fb12b70Safresh1my $udp = getprotobyname('udp') 336fb12b70Safresh1 or note "getprotobyname('udp') failed: $!"; 346fb12b70Safresh1 356fb12b70Safresh1my $local = gethostbyname('localhost') 366fb12b70Safresh1 or note "gethostbyname('localhost') failed: $!"; 376fb12b70Safresh1 386fb12b70Safresh1my $fork = $Config{d_fork} || $Config{d_pseudofork}; 396fb12b70Safresh1 406fb12b70Safresh1{ 416fb12b70Safresh1 # basic socket creation 426fb12b70Safresh1 socket(my $sock, PF_INET, SOCK_STREAM, $tcp) 436fb12b70Safresh1 or skip_all('socket() for tcp failed ($!), nothing else will work'); 446fb12b70Safresh1 ok(close($sock), "close the socket"); 456fb12b70Safresh1} 466fb12b70Safresh1 47b46d8ef2Safresh1SKIP: 48b46d8ef2Safresh1{ 49b46d8ef2Safresh1 $udp 50b46d8ef2Safresh1 or skip "No udp", 1; 51b46d8ef2Safresh1 # [perl #133853] failed socket creation didn't set error 52b46d8ef2Safresh1 # for bad parameters on Win32 53b46d8ef2Safresh1 $! = 0; 54b46d8ef2Safresh1 socket(my $sock, PF_INET, SOCK_STREAM, $udp) 55b46d8ef2Safresh1 and skip "managed to make a UDP stream socket", 1; 56b46d8ef2Safresh1 ok(0+$!, "error set on failed socket()"); 57b46d8ef2Safresh1} 58b46d8ef2Safresh1 596fb12b70Safresh1SKIP: { 606fb12b70Safresh1 # test it all in TCP 619f11ffb7Safresh1 $local or skip("No localhost", 3); 626fb12b70Safresh1 636fb12b70Safresh1 ok(socket(my $serv, PF_INET, SOCK_STREAM, $tcp), "make a tcp socket"); 646fb12b70Safresh1 my $bind_at = pack_sockaddr_in(0, $local); 656fb12b70Safresh1 ok(bind($serv, $bind_at), "bind works") 669f11ffb7Safresh1 or skip("Couldn't bind to localhost", 4); 676fb12b70Safresh1 my $bind_name = getsockname($serv); 686fb12b70Safresh1 ok($bind_name, "getsockname() on bound socket"); 696fb12b70Safresh1 my ($bind_port) = unpack_sockaddr_in($bind_name); 706fb12b70Safresh1 716fb12b70Safresh1 print "# port $bind_port\n"; 726fb12b70Safresh1 736fb12b70Safresh1 SKIP: 746fb12b70Safresh1 { 756fb12b70Safresh1 ok(listen($serv, 5), "listen() works") 766fb12b70Safresh1 or diag "listen error: $!"; 776fb12b70Safresh1 789f11ffb7Safresh1 $fork or skip("No fork", 2); 796fb12b70Safresh1 my $pid = fork; 806fb12b70Safresh1 my $send_data = "test" x 50_000; 816fb12b70Safresh1 if ($pid) { 826fb12b70Safresh1 # parent 836fb12b70Safresh1 ok(socket(my $accept, PF_INET, SOCK_STREAM, $tcp), 846fb12b70Safresh1 "make accept tcp socket"); 856fb12b70Safresh1 ok(my $addr = accept($accept, $serv), "accept() works") 866fb12b70Safresh1 or diag "accept error: $!"; 879f11ffb7Safresh1 binmode $accept; 889f11ffb7Safresh1 SKIP: { 899f11ffb7Safresh1 skip "no fcntl", 1 unless $Config{d_fcntl}; 909f11ffb7Safresh1 my $acceptfd = fileno($accept); 919f11ffb7Safresh1 fresh_perl_is(qq( 929f11ffb7Safresh1 print open(F, "+<&=$acceptfd") ? 1 : 0, "\\n"; 939f11ffb7Safresh1 ), "0\n", {}, "accepted socket not inherited across exec"); 949f11ffb7Safresh1 } 956fb12b70Safresh1 my $sent_total = 0; 966fb12b70Safresh1 while ($sent_total < length $send_data) { 976fb12b70Safresh1 my $sent = send($accept, substr($send_data, $sent_total), 0); 986fb12b70Safresh1 defined $sent or last; 996fb12b70Safresh1 $sent_total += $sent; 1006fb12b70Safresh1 } 1016fb12b70Safresh1 my $shutdown = shutdown($accept, 1); 1026fb12b70Safresh1 1036fb12b70Safresh1 # wait for the remote to close so data isn't lost in 1046fb12b70Safresh1 # transit on a certain broken implementation 1056fb12b70Safresh1 <$accept>; 1066fb12b70Safresh1 # child tests are printed once we hit eof 1076fb12b70Safresh1 curr_test(curr_test()+5); 1086fb12b70Safresh1 waitpid($pid, 0); 1096fb12b70Safresh1 1106fb12b70Safresh1 ok($shutdown, "shutdown() works"); 1116fb12b70Safresh1 } 1126fb12b70Safresh1 elsif (defined $pid) { 1139f11ffb7Safresh1 curr_test(curr_test()+3); 1146fb12b70Safresh1 #sleep 1; 1156fb12b70Safresh1 # child 1166fb12b70Safresh1 ok_child(close($serv), "close server socket in child"); 1176fb12b70Safresh1 ok_child(socket(my $child, PF_INET, SOCK_STREAM, $tcp), 1186fb12b70Safresh1 "make child tcp socket"); 1196fb12b70Safresh1 1206fb12b70Safresh1 ok_child(connect($child, $bind_name), "connect() works") 1216fb12b70Safresh1 or diag "connect error: $!"; 1229f11ffb7Safresh1 binmode $child; 1236fb12b70Safresh1 my $buf; 1246fb12b70Safresh1 my $recv_peer = recv($child, $buf, 1000, 0); 125b8851fccSafresh1 { 1269f11ffb7Safresh1 local $TODO = "[perl #122657] Hurd doesn't populate sin_len correctly" 127b8851fccSafresh1 if $^O eq "gnu"; 1286fb12b70Safresh1 # [perl #118843] 129b8851fccSafresh1 ok_child($recv_peer eq '' || $recv_peer eq getpeername $child, 1306fb12b70Safresh1 "peer from recv() should be empty or the remote name"); 131b8851fccSafresh1 } 1326fb12b70Safresh1 while(defined recv($child, my $tmp, 1000, 0)) { 1336fb12b70Safresh1 last if length $tmp == 0; 1346fb12b70Safresh1 $buf .= $tmp; 1356fb12b70Safresh1 } 1366fb12b70Safresh1 is_child($buf, $send_data, "check we received the data"); 1376fb12b70Safresh1 close($child); 1386fb12b70Safresh1 end_child(); 1396fb12b70Safresh1 1406fb12b70Safresh1 exit(0); 1416fb12b70Safresh1 } 1426fb12b70Safresh1 else { 1436fb12b70Safresh1 # failed to fork 1446fb12b70Safresh1 diag "fork() failed $!"; 1459f11ffb7Safresh1 skip("fork() failed", 2); 1466fb12b70Safresh1 } 1476fb12b70Safresh1 } 1486fb12b70Safresh1} 1496fb12b70Safresh1 150b46d8ef2Safresh1SKIP: { 151b46d8ef2Safresh1 # test recv/send handling with :utf8 152b46d8ef2Safresh1 # this doesn't appear to have been tested previously, this is 153b46d8ef2Safresh1 # separate to avoid interfering with the data expected above 154b46d8ef2Safresh1 $local or skip("No localhost", 1); 155b46d8ef2Safresh1 $fork or skip("No fork", 1); 156b46d8ef2Safresh1 157b46d8ef2Safresh1 note "recv/send :utf8 tests"; 158b46d8ef2Safresh1 ok(socket(my $serv, PF_INET, SOCK_STREAM, $tcp), "make a tcp socket (recv/send :utf8 handling)"); 159b46d8ef2Safresh1 my $bind_at = pack_sockaddr_in(0, $local); 160b46d8ef2Safresh1 ok(bind($serv, $bind_at), "bind works") 161b46d8ef2Safresh1 or skip("Couldn't bind to localhost", 1); 162b46d8ef2Safresh1 my $bind_name = getsockname($serv); 163b46d8ef2Safresh1 ok($bind_name, "getsockname() on bound socket"); 164b46d8ef2Safresh1 my ($bind_port) = unpack_sockaddr_in($bind_name); 165b46d8ef2Safresh1 166b46d8ef2Safresh1 print "# port $bind_port\n"; 167b46d8ef2Safresh1 168b46d8ef2Safresh1 SKIP: 169b46d8ef2Safresh1 { 170b46d8ef2Safresh1 ok(listen($serv, 5), "listen() works") 171b46d8ef2Safresh1 or diag "listen error: $!"; 172b46d8ef2Safresh1 173b46d8ef2Safresh1 my $pid = fork; 174b46d8ef2Safresh1 my $send_data = "test\x80\xFF" x 50_000; 175b46d8ef2Safresh1 if ($pid) { 176b46d8ef2Safresh1 # parent 177b46d8ef2Safresh1 ok(socket(my $accept, PF_INET, SOCK_STREAM, $tcp), 178b46d8ef2Safresh1 "make accept tcp socket"); 179b46d8ef2Safresh1 ok(my $addr = accept($accept, $serv), "accept() works") 180b46d8ef2Safresh1 or diag "accept error: $!"; 181b46d8ef2Safresh1 binmode $accept, ':raw:utf8'; 182b46d8ef2Safresh1 ok(!eval { send($accept, "ABC", 0); 1 }, 183b46d8ef2Safresh1 "should die on send to :utf8 socket"); 184b46d8ef2Safresh1 binmode $accept; 185b46d8ef2Safresh1 # check bytes will be sent 186b46d8ef2Safresh1 utf8::upgrade($send_data); 187b46d8ef2Safresh1 my $sent_total = 0; 188b46d8ef2Safresh1 while ($sent_total < length $send_data) { 189b46d8ef2Safresh1 my $sent = send($accept, substr($send_data, $sent_total), 0); 190b46d8ef2Safresh1 defined $sent or last; 191b46d8ef2Safresh1 $sent_total += $sent; 192b46d8ef2Safresh1 } 193b46d8ef2Safresh1 my $shutdown = shutdown($accept, 1); 194b46d8ef2Safresh1 195b46d8ef2Safresh1 # wait for the remote to close so data isn't lost in 196b46d8ef2Safresh1 # transit on a certain broken implementation 197b46d8ef2Safresh1 <$accept>; 198b46d8ef2Safresh1 # child tests are printed once we hit eof 199b46d8ef2Safresh1 curr_test(curr_test()+6); 200b46d8ef2Safresh1 waitpid($pid, 0); 201b46d8ef2Safresh1 202b46d8ef2Safresh1 ok($shutdown, "shutdown() works"); 203b46d8ef2Safresh1 } 204b46d8ef2Safresh1 elsif (defined $pid) { 205b46d8ef2Safresh1 curr_test(curr_test()+3); 206b46d8ef2Safresh1 #sleep 1; 207b46d8ef2Safresh1 # child 208b46d8ef2Safresh1 ok_child(close($serv), "close server socket in child"); 209b46d8ef2Safresh1 ok_child(socket(my $child, PF_INET, SOCK_STREAM, $tcp), 210b46d8ef2Safresh1 "make child tcp socket"); 211b46d8ef2Safresh1 212b46d8ef2Safresh1 ok_child(connect($child, $bind_name), "connect() works") 213b46d8ef2Safresh1 or diag "connect error: $!"; 214b46d8ef2Safresh1 binmode $child, ':raw:utf8'; 215b46d8ef2Safresh1 my $buf; 216b46d8ef2Safresh1 217b46d8ef2Safresh1 ok_child(!eval { recv($child, $buf, 1000, 0); 1 }, 218b46d8ef2Safresh1 "recv on :utf8 should die"); 219b46d8ef2Safresh1 is_child($buf, "", "buf shouldn't contain anything"); 220b46d8ef2Safresh1 binmode $child; 221b46d8ef2Safresh1 my $recv_peer = recv($child, $buf, 1000, 0); 222b46d8ef2Safresh1 while(defined recv($child, my $tmp, 1000, 0)) { 223b46d8ef2Safresh1 last if length $tmp == 0; 224b46d8ef2Safresh1 $buf .= $tmp; 225b46d8ef2Safresh1 } 226b46d8ef2Safresh1 is_child($buf, $send_data, "check we received the data"); 227b46d8ef2Safresh1 close($child); 228b46d8ef2Safresh1 end_child(); 229b46d8ef2Safresh1 230b46d8ef2Safresh1 exit(0); 231b46d8ef2Safresh1 } 232b46d8ef2Safresh1 else { 233b46d8ef2Safresh1 # failed to fork 234b46d8ef2Safresh1 diag "fork() failed $!"; 235b46d8ef2Safresh1 skip("fork() failed", 2); 236b46d8ef2Safresh1 } 237b46d8ef2Safresh1 } 238b46d8ef2Safresh1} 239b46d8ef2Safresh1 240c0dd97bfSafresh1SKIP: 241c0dd97bfSafresh1{ 242c0dd97bfSafresh1 eval { require Errno; defined &Errno::EMFILE } 243c0dd97bfSafresh1 or skip "Can't load Errno or EMFILE not defined", 1; 2449f11ffb7Safresh1 # stdio might return strange values in errno if it runs 2459f11ffb7Safresh1 # out of FILE entries, and does on darwin 2469f11ffb7Safresh1 $^O eq "darwin" && exists $ENV{PERLIO} && $ENV{PERLIO} =~ /stdio/ 2479f11ffb7Safresh1 and skip "errno values from stdio are unspecified", 1; 248c0dd97bfSafresh1 my @socks; 249c0dd97bfSafresh1 my $sock_limit = 1000; # don't consume every file in the system 250c0dd97bfSafresh1 # Default limits on various systems I have: 251c0dd97bfSafresh1 # 65536 - Linux 252c0dd97bfSafresh1 # 256 - Solaris 253c0dd97bfSafresh1 # 128 - NetBSD 254c0dd97bfSafresh1 # 256 - Cygwin 255c0dd97bfSafresh1 # 256 - darwin 256c0dd97bfSafresh1 while (@socks < $sock_limit) { 257c0dd97bfSafresh1 socket my $work, PF_INET, SOCK_STREAM, $tcp 258c0dd97bfSafresh1 or last; 259c0dd97bfSafresh1 push @socks, $work; 260c0dd97bfSafresh1 } 261c0dd97bfSafresh1 @socks == $sock_limit 262c0dd97bfSafresh1 and skip "Didn't run out of open handles", 1; 263c0dd97bfSafresh1 is(0+$!, Errno::EMFILE(), "check correct errno for too many files"); 264c0dd97bfSafresh1} 265c0dd97bfSafresh1 2669f11ffb7Safresh1{ 2679f11ffb7Safresh1 my $sock; 2689f11ffb7Safresh1 my $proto = getprotobyname('tcp'); 2699f11ffb7Safresh1 socket($sock, PF_INET, SOCK_STREAM, $proto); 2709f11ffb7Safresh1 accept($sock, $sock); 2719f11ffb7Safresh1 ok('RT #7614: still alive after accept($sock, $sock)'); 2729f11ffb7Safresh1} 2739f11ffb7Safresh1 2749f11ffb7Safresh1SKIP: { 2759f11ffb7Safresh1 skip "no fcntl", 1 unless $Config{d_fcntl}; 2769f11ffb7Safresh1 my $sock; 2779f11ffb7Safresh1 socket($sock, PF_INET, SOCK_STREAM, $tcp) or die "socket: $!"; 2789f11ffb7Safresh1 my $sockfd = fileno($sock); 2799f11ffb7Safresh1 fresh_perl_is(qq( 2809f11ffb7Safresh1 print open(F, "+<&=$sockfd") ? 1 : 0, "\\n"; 2819f11ffb7Safresh1 ), "0\n", {}, "fresh socket not inherited across exec"); 2829f11ffb7Safresh1} 2839f11ffb7Safresh1 284eac174f2Safresh1SKIP: 285eac174f2Safresh1{ 286eac174f2Safresh1 my $val; 287eac174f2Safresh1 { 288eac174f2Safresh1 package SetsockoptMagic; 289eac174f2Safresh1 sub TIESCALAR { bless {}, shift } 290eac174f2Safresh1 sub FETCH { $val } 291eac174f2Safresh1 } 292eac174f2Safresh1 # setsockopt() magic 293eac174f2Safresh1 socket(my $sock, PF_INET, SOCK_STREAM, $tcp); 294eac174f2Safresh1 $val = 0; 295eac174f2Safresh1 # set a known value 296eac174f2Safresh1 ok(setsockopt($sock, SOL_SOCKET, SO_REUSEADDR, 1), 297eac174f2Safresh1 "set known SO_REUSEADDR"); 298eac174f2Safresh1 isnt(getsockopt($sock, SOL_SOCKET, SO_REUSEADDR), pack("i", 0), 299eac174f2Safresh1 "check that worked"); 300eac174f2Safresh1 tie my $m, "SetsockoptMagic"; 301eac174f2Safresh1 # trigger the magic with the value 0 302eac174f2Safresh1 $val = pack("i", 0); 303eac174f2Safresh1 my $temp = $m; 304eac174f2Safresh1 305eac174f2Safresh1 $val = 1; 306eac174f2Safresh1 ok(setsockopt($sock, SOL_SOCKET, SO_REUSEADDR, $m), 307eac174f2Safresh1 "set SO_REUSEADDR from magic"); 308eac174f2Safresh1 isnt(getsockopt($sock, SOL_SOCKET, SO_REUSEADDR), pack("i", 0), 309eac174f2Safresh1 "check SO_REUSEADDR set correctly"); 310e0680481Safresh1 311e0680481Safresh1 # test whether boolean value treated as a number 312e0680481Safresh1 ok(setsockopt($sock, SOL_SOCKET, SO_REUSEADDR, !1), 313e0680481Safresh1 "clear SO_REUSEADDR by a boolean false"); 314e0680481Safresh1 is(getsockopt($sock, SOL_SOCKET, SO_REUSEADDR), pack("i", 0), 315e0680481Safresh1 "check SO_REUSEADDR cleared correctly"); 316e0680481Safresh1 ok(setsockopt($sock, SOL_SOCKET, SO_REUSEADDR, !0), 317e0680481Safresh1 "set SO_REUSEADDR by a boolean true"); 318e0680481Safresh1 isnt(getsockopt($sock, SOL_SOCKET, SO_REUSEADDR), pack("i", 0), 319e0680481Safresh1 "check SO_REUSEADDR set correctly"); 320e0680481Safresh1} 321e0680481Safresh1 322e0680481Safresh1# GH #18642 - test whether setsockopt works with a numeric OPTVAL which also 323e0680481Safresh1# has a cached stringified value 324e0680481Safresh1SKIP: { 325e0680481Safresh1 defined(my $IPPROTO_IP = eval { Socket::IPPROTO_IP() }) 326e0680481Safresh1 or skip 'no IPPROTO_IP', 4; 327e0680481Safresh1 defined(my $IP_TTL = eval { Socket::IP_TTL() }) 328e0680481Safresh1 or skip 'no IP_TTL', 4; 329e0680481Safresh1 330e0680481Safresh1 my $sock; 331e0680481Safresh1 socket($sock, PF_INET, SOCK_STREAM, $tcp) or BAIL_OUT "socket: $!"; 332e0680481Safresh1 333e0680481Safresh1 my $ttl = 7; 334e0680481Safresh1 my $integer_only_ttl = 0 + $ttl; 335e0680481Safresh1 ok(setsockopt($sock, $IPPROTO_IP, $IP_TTL, $integer_only_ttl), 336e0680481Safresh1 'setsockopt with an integer-only OPTVAL'); 337e0680481Safresh1 my $set_ttl = getsockopt($sock, $IPPROTO_IP, $IP_TTL); 338e0680481Safresh1 is(unpack('i', $set_ttl // ''), $ttl, 'TTL set to desired value'); 339e0680481Safresh1 340e0680481Safresh1 my $also_string_ttl = $ttl; 341e0680481Safresh1 my $string = "$also_string_ttl"; 342e0680481Safresh1 ok(setsockopt($sock, $IPPROTO_IP, $IP_TTL, $also_string_ttl), 343e0680481Safresh1 'setsockopt with an integer OPTVAL with stringified value'); 344e0680481Safresh1 $set_ttl = getsockopt($sock, $IPPROTO_IP, $IP_TTL); 345e0680481Safresh1 is(unpack('i', $set_ttl // ''), $ttl, 'TTL set to desired value'); 346e0680481Safresh1} 347e0680481Safresh1 348e0680481Safresh1# GH #19892 349e0680481Safresh1SKIP: { 350e0680481Safresh1 eval { Socket::IPPROTO_TCP(); 1 } or skip 'no IPPROTO_TCP', 1; 351e0680481Safresh1 eval { Socket::SOL_SOCKET(); 1 } or skip 'no SOL_SOCKET', 1; 352e0680481Safresh1 eval { Socket::SO_SNDBUF(); 1 } or skip 'no SO_SNDBUF', 1; 353e0680481Safresh1 skip 'setting socket buffer size requires elevated privileges', 1 if $^O eq 'VMS'; 354e0680481Safresh1 355e0680481Safresh1 # The value of SNDBUF_SIZE constant below is changed from #19892 testcase; 356e0680481Safresh1 # original "262144" may be clamped on low-memory systems. 357e0680481Safresh1 fresh_perl_is(<<'EOP', "Ok.\n", {}, 'setsockopt works for a constant that is once stringified'); 358e0680481Safresh1use warnings; 359e0680481Safresh1use strict; 360e0680481Safresh1 361e0680481Safresh1use Socket qw'PF_INET SOCK_STREAM IPPROTO_TCP SOL_SOCKET SO_SNDBUF'; 362e0680481Safresh1 363e0680481Safresh1use constant { SNDBUF_SIZE => 32768 }; 364e0680481Safresh1 365e0680481Safresh1socket(my $sock, PF_INET, SOCK_STREAM, IPPROTO_TCP) 366e0680481Safresh1 or die "Could not create socket - $!\n"; 367e0680481Safresh1 368e0680481Safresh1setsockopt($sock,SOL_SOCKET,SO_SNDBUF,SNDBUF_SIZE) 369e0680481Safresh1 or die "Could not set SO_SNDBUF on socket - $!\n"; 370e0680481Safresh1 371e0680481Safresh1my $sndBuf=getsockopt($sock,SOL_SOCKET,SO_SNDBUF) 372e0680481Safresh1 or die "Could not get SO_SNDBUF on socket - $!\n"; 373e0680481Safresh1 374e0680481Safresh1$sndBuf=unpack('i',$sndBuf); 375e0680481Safresh1 376e0680481Safresh1die "Unexpected SO_SNDBUF value: $sndBuf\n" 377e0680481Safresh1 unless($sndBuf == SNDBUF_SIZE || $sndBuf == 2*SNDBUF_SIZE); 378e0680481Safresh1 379e0680481Safresh1print "Ok.\n"; 380e0680481Safresh1exit; 381e0680481Safresh1 382e0680481Safresh1sub bug {SNDBUF_SIZE.''} 383e0680481Safresh1EOP 384eac174f2Safresh1} 385eac174f2Safresh1 3866fb12b70Safresh1done_testing(); 3876fb12b70Safresh1 3886fb12b70Safresh1my @child_tests; 3896fb12b70Safresh1sub ok_child { 3906fb12b70Safresh1 my ($ok, $note) = @_; 391b8851fccSafresh1 push @child_tests, ( $ok ? "ok " : "not ok ") . curr_test() . " - $note " 392b8851fccSafresh1 . ( $TODO ? "# TODO $TODO" : "" ) . "\n"; 3936fb12b70Safresh1 curr_test(curr_test()+1); 3946fb12b70Safresh1} 3956fb12b70Safresh1 3966fb12b70Safresh1sub is_child { 3976fb12b70Safresh1 my ($got, $want, $note) = @_; 3986fb12b70Safresh1 ok_child($got eq $want, $note); 3996fb12b70Safresh1} 4006fb12b70Safresh1 4016fb12b70Safresh1sub end_child { 4026fb12b70Safresh1 print @child_tests; 4036fb12b70Safresh1} 4049f11ffb7Safresh1 405