1use strict; 2use warnings; 3 4# The things done in this test can trigger a buggy return value on some 5# platforms. This prevents that. The harness should catch actual failures. If 6# no harness is active then we will NOT sanitize the exit value, false fails 7# are better than false passes. 8END { $? = 0 if $ENV{HARNESS_ACTIVE} } 9 10# Some platforms throw a sigpipe in this test, we can ignore it. 11BEGIN { $SIG{PIPE} = 'IGNORE' } 12 13BEGIN { local ($@, $?, $!); eval { require threads } } 14use Test2::Tools::Tiny; 15use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK/; 16use Test2::IPC; 17use Test2::API qw/test2_ipc_set_timeout test2_ipc_get_timeout/; 18 19my $plan = 2; 20$plan += 2 if CAN_REALLY_FORK; 21$plan += 2 if CAN_THREAD && threads->can('is_joinable'); 22plan $plan; 23 24is(test2_ipc_get_timeout(), 30, "got default timeout"); 25test2_ipc_set_timeout(10); 26is(test2_ipc_get_timeout(), 10, "hanged the timeout"); 27 28if (CAN_REALLY_FORK) { 29 note "Testing process waiting"; 30 my ($ppiper, $ppipew); 31 pipe($ppiper, $ppipew) or die "Could not create pipe for fork"; 32 33 my $proc = fork(); 34 die "Could not fork!" unless defined $proc; 35 36 unless ($proc) { 37 local $SIG{ALRM} = sub { die "PROCESS TIMEOUT" }; 38 alarm 15; 39 my $ignore = <$ppiper>; 40 exit 0; 41 } 42 43 my $exit; 44 my $warnings = warnings { 45 $exit = Test2::API::Instance::_ipc_wait(1); 46 }; 47 is($exit, 255, "Exited 255"); 48 like($warnings->[0], qr/Timeout waiting on child processes/, "Warned about timeout"); 49 print $ppipew "end\n"; 50 51 close($ppiper); 52 close($ppipew); 53} 54 55if (CAN_THREAD) { 56 note "Testing thread waiting"; 57 my ($tpiper, $tpipew); 58 pipe($tpiper, $tpipew) or die "Could not create pipe for threads"; 59 60 my $thread = threads->create( 61 sub { 62 local $SIG{ALRM} = sub { die "THREAD TIMEOUT" }; 63 alarm 15; 64 my $ignore = <$tpiper>; 65 } 66 ); 67 68 if ($thread->can('is_joinable')) { 69 my $exit; 70 my $warnings = warnings { 71 $exit = Test2::API::Instance::_ipc_wait(1); 72 }; 73 is($exit, 255, "Exited 255"); 74 like($warnings->[0], qr/Timeout waiting on child thread/, "Warned about timeout"); 75 } 76 else { 77 note "threads.pm is too old for a thread joining timeout :-("; 78 } 79 print $tpipew "end\n"; 80 81 close($tpiper); 82 close($tpipew); 83} 84