1*5759b3d2Safresh1use strict; 2*5759b3d2Safresh1use warnings; 3*5759b3d2Safresh1use Test2::IPC; 4*5759b3d2Safresh1use Test2::Tools::Tiny; 5*5759b3d2Safresh1use Test2::API qw/context intercept test2_stack/; 6*5759b3d2Safresh1use Test2::Util qw/CAN_FORK/; 7*5759b3d2Safresh1 8*5759b3d2Safresh1BEGIN { 9*5759b3d2Safresh1 skip_all "System cannot fork" unless CAN_FORK; 10*5759b3d2Safresh1} 11*5759b3d2Safresh1 12*5759b3d2Safresh1my $events = intercept { 13*5759b3d2Safresh1 Test2::API::run_subtest("this subtest forks" => sub { 14*5759b3d2Safresh1 if (fork) { 15*5759b3d2Safresh1 wait; 16*5759b3d2Safresh1 isnt($?, 0, "subprocess died"); 17*5759b3d2Safresh1 } else { 18*5759b3d2Safresh1 # Prevent the exception from being rendered to STDERR, people have 19*5759b3d2Safresh1 # complained about STDERR noise in tests before. 20*5759b3d2Safresh1 close STDERR; 21*5759b3d2Safresh1 die "# Expected warning from subtest"; 22*5759b3d2Safresh1 }; 23*5759b3d2Safresh1 }, {no_fork => 1}); 24*5759b3d2Safresh1}; 25*5759b3d2Safresh1 26*5759b3d2Safresh1my @subtests = grep {; $_->isa('Test2::Event::Subtest') } @$events; 27*5759b3d2Safresh1 28*5759b3d2Safresh1if (is(@subtests, 1, "only one subtest run, effectively")) { 29*5759b3d2Safresh1 my @subokay = grep {; $_->facets->{assert} } 30*5759b3d2Safresh1 @{ $subtests[0]->subevents }; 31*5759b3d2Safresh1 is(@subokay, 1, "we got one test result inside the subtest"); 32*5759b3d2Safresh1 ok(! $subokay[0]->causes_fail, "...and it passed"); 33*5759b3d2Safresh1} else { 34*5759b3d2Safresh1 # give up, we're already clearly broken 35*5759b3d2Safresh1} 36*5759b3d2Safresh1 37*5759b3d2Safresh1done_testing; 38