1#!perl 2# -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/08-*.t" -*- 3use strict; 4use warnings; 5 6use Config; 7 8my $code = ''; 9my $flags = ''; 10 11# Thank you, http://search.cpan.org/src/DAGOLDEN/Class-InsideOut-1.02/t/05_forking.t 12 13# If Win32, fork() is done with threads, so we need various things 14if ( $^O =~ /^(?:MSWin32|NetWare|WinCE)\z/ ) { 15 16 $code .= <<'COVERAGE'; 17# don't run this at all under Devel::Cover 18if ( $ENV{HARNESS_PERL_SWITCHES} && 19 $ENV{HARNESS_PERL_SWITCHES} =~ /Devel::Cover/ ) { 20 plan skip_all => 'Devel::Cover not compatible with Win32 pseudo-fork'; 21} 22COVERAGE 23 24 # skip if threads not available for some reasons 25 if ( ! $Config{useithreads} ) { 26 $code .= <<NOTHREADS; 27plan skip_all => "Win32 fork() support requires threads"; 28NOTHREADS 29 } 30 31 # skip if perl < 5.8 32 if ( $] < 5.008 ) { 33 $code .= <<NOTHREADS; 34plan skip_all => "Win32 fork() support requires perl 5.8"; 35NOTHREADS 36 } 37} 38elsif (!$Config{d_fork}) { 39 $code .= <<NOFORK; 40plan skip_all => 'Fork tests are irrelevant without fork()'; 41NOFORK 42} 43else { 44 $flags = ' -T'; 45 $code .= <<DIAG 46BEGIN { 47 diag('Real fork; taint checks enabled'); 48} 49DIAG 50} 51 52(my $file = __FILE__) =~ s/\.PL$/.t/; 53open my $fh, '>', $file or die "Cannot open '$file': '$!'"; 54 55print $fh "#!perl$flags\n", <<'CODA', $code; 56# -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/08-*.t" -*-; 57 58BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile 59use Test::More tests => 15; 60use strict; 61use warnings; 62 63CODA 64 65print $fh <DATA>; 66 67exit 0; 68 69__DATA__ 70 71my $flag; 72BEGIN { 73 *CORE::GLOBAL::exit = sub(;$) { 74 if ($flag) { 75 pass("The final test: The outer CORE::GLOBAL::exit is eventually called"); 76 } 77 else { 78 fail("The outer CORE::GLOBAL::exit is called too soon!"); 79 } 80 CORE::exit(@_ ? shift : 0); 81 }; 82} 83 84BEGIN { 85 use_ok( 'Test::Trap' ); 86} 87 88# check that the setup works -- the exit is still trapped: 89trap { exit }; 90is( $trap->exit, 0, "Trapped the first exit"); 91 92# check that the exit from the forked-off process reverts to the inner 93# CORE::GLOBAL::exit, not the outer 94trap { 95 *CORE::GLOBAL::exit = sub(;$) { 96 pass("The inner CORE::GLOBAL::exit is called from the child"); 97 CORE::exit(@_ ? shift : 0); 98 }; 99 trap { 100 fork; 101 exit; 102 }; 103 wait; # let the child finish first 104 # Increment the counter correctly ... 105 my $Test = Test::More->builder; 106 $Test->current_test( $Test->current_test + 1 ); 107 is( $trap->exit, 0, "Trapped the inner exit"); 108}; 109like( $trap->stderr, qr/^Subroutine (?:CORE::GLOBAL::)?exit \Qredefined at ${\__FILE__} line/, 'Override warning' ); 110 111trap { 112 trap{ 113 trap { 114 fork; 115 exit; 116 }; 117 wait; 118 is( $trap->exit, 0, "Trapped the inner exit" ); 119 } 120}; 121is( $trap->leaveby, 'return', 'Should return just once, okay?' ); 122 123# Output from forked-off processes? 124my $me; 125trap { 126 $me = fork ? 'parent' : 'child'; 127 print "\u$me print\n"; 128 warn "\u$me warning\n"; 129 wait, exit $$ if $me eq 'parent'; 130}; 131CORE::exit(0) if $me eq 'child'; 132is( $trap->exit, $$, "Trapped the parent exit" ); 133like( $trap->stdout, qr/^(Parent print\nChild print\n|Child print\nParent print\n)/, 'STDOUT from both processes!' ); 134like( $trap->stderr, qr/^(Parent warning\nChild warning\n|Child warning\nParent warning\n)/, 'STDERR from both processes!' ); 135is_deeply( $trap->warn, ["Parent warning\n"], 'Warnings from the parent only' ); 136 137# STDERR from forked-off processes, with a closed STDIN & STDOUT? 138trap { 139 close STDOUT; 140 trap { 141 my $me = fork ? 'parent' : 'child'; 142 print "\u$me print\n"; 143 warn "\u$me warning\n"; 144 wait, exit $$ if $me eq 'parent'; 145 CORE::exit(0); 146 }; 147 is( $trap->exit, $$, "Trapped the parent exit" ); 148 is( $trap->stdout, '', 'STDOUT from both processes is nil -- the handle is closed!' ); 149 like( $trap->stderr, qr/\A(?=.*^Parent warning$)(?=.*^Child warning$)/ms, 'STDERR from both processes!' ); 150}; 151 152$flag++; # the exit test will now pass -- in the forked-off processes it will fail! 153exit; 154