1#!perl 2# -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/11-*.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/11-*.t" -*-; 57 58BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile 59use Test::More; 60use strict; 61use warnings; 62 63CODA 64 65print $fh <DATA>; 66 67exit 0; 68 69__DATA__ 70 71use File::Temp qw( tempfile ); 72 73use Test::Trap::Builder::SystemSafe; 74 75use Test::Trap qw( trap $T :flow:stderr(systemsafe):stdout(systemsafe):warn ); 76 77BEGIN { 78 # silence some warnings that make coverage reports hard to get at 79 if ($Storable::VERSION) { 80 eval { 81 eval { no warnings; Storable::retrieve('.') }; # silly, but hopefully safe ... 82 my $_r = \&Storable::_retrieve; 83 no warnings 'redefine'; 84 *Storable::_retrieve = sub { 85 no warnings; 86 local $SIG{__WARN__} = sub {}; 87 $_r->(@_); 88 }; 89 }; 90 } 91 if ($Devel::Cover::DB::Structure::VERSION) { 92 eval { 93 my $d = \&Devel::Cover::DB::Structure::digest; 94 no warnings 'redefine'; 95 *Devel::Cover::DB::Structure::digest = sub { 96 no warnings; 97 local $SIG{__WARN__} = sub {}; 98 $d->(@_); 99 }; 100 }; 101 } 102} 103 104# Protect against tainted PATH &c ... 105$ENV{PATH} = ''; 106$ENV{CDPATH} = ''; 107$ENV{ENV} = ''; 108$ENV{BASH_ENV} = ''; 109 110my ($PERL) = $^X =~ /^([\w.\/:\\~-]+)$/; 111if ($PERL) { 112 plan tests => 3 + 6*6 + 4; 113} 114else { 115 plan skip_all => "Odd perl path: $^X"; 116} 117 118 119my $desc = "fdopen()ed file handle"; 120SKIP: { 121 skip 'These tests are irrelevant on old perls', 3 if $] < 5.008; 122 open my $fh, '>&=STDOUT' or die "Cannot fdopen STDOUT: '$!'"; 123 exit diag "Got fileno " . fileno($fh) unless fileno($fh)==1; 124 125 # Basic error situation: STDOUT cannot be reopened on fd-1: 126 eval { trap { system $PERL, '-e', 'binmode STDOUT; binmode STDERR; warn qq(0123456789Warning\n); print qq(Printing\n)'; exit 1 } }; 127 like( $@, qr/^\QCannot get the desired descriptor, '1' (could it be that it is fdopened and so still open?)/, "$desc: exception string" ); 128 is( fileno STDOUT, undef, "$desc: STDOUT should be left closed by now") 129 or exit diag "Got STDOUT with fd " . fileno(STDOUT); 130 is( fileno STDERR, 2, "$desc: STDERR fileno should be unchanged"); 131 132 unless (fileno(STDOUT) or open STDOUT, '>&=' . fileno $fh) { 133 exit diag "Cannot fdopen fno ".fileno($fh).": '$!'"; 134 } 135 if (fileno $fh and !close $fh) { 136 exit diag "Cannot close: '$!'"; 137 } 138} 139 140$desc = "simple fork test"; 141trap { 142 fork ? wait : do { warn "0123456789Warning\n"; print "Printing\n" }; 143 exit 1; 144}; 145is( $T->exit, 1, "$desc: exit(1)" ); 146is( $T->stdout, "Printing\n", "$desc: system() STDOUT" ); 147is( $T->stderr, "0123456789Warning\n", "$desc: system() STDERR" ); 148is( join("\n", @{$T->warn}), '', "$desc: No warnings" ); 149 150# Have the file handles been re-opened on the right descriptors? 151is( fileno STDOUT, 1, "$desc: STDOUT fileno should be unchanged"); 152is( fileno STDERR, 2, "$desc: STDERR fileno should be unchanged"); 153 154# Basic messing-up -- protect the handles with an outer trap: 155trap { 156 for (1..5) { 157 my $desc = "Take $_"; 158 my $OUTFNO = 1; 159 my $EXPECT = "Printing\n"; 160 if ($_ > 2) { 161 close STDIN; 162 $desc .= ' - STDIN closed'; 163 } 164 if ($_ > 3) { 165 close STDOUT; 166 undef $OUTFNO; 167 $EXPECT = ''; 168 $desc .= ' - STDOUT closed'; 169 } 170 171 # Output from forked-off processes? 172 trap { 173 my @args = ($PERL, '-e', 'binmode STDOUT; binmode STDERR; warn qq(0123456789Warning\n); print qq(Printing\n)'); 174 system @args and die "system @args failed with $?"; 175 exit 1; 176 }; 177 is( $T->exit, 1, "$desc: exit(1)" ) 178 or $T->diag_all; 179 is( $T->stdout, $EXPECT, "$desc: system() STDOUT" ); 180 is( $T->stderr, "0123456789Warning\n", "$desc: system() STDERR" ); 181 is( join("\n", @{$T->warn}), '', "$desc: No warnings" ); 182 183 # Have the file handles been re-opened on the right descriptors? 184 is( fileno STDOUT, $OUTFNO, "$desc: STDOUT fileno should be unchanged"); 185 is( fileno STDERR, 2, "$desc: STDERR fileno should be unchanged"); 186 } 187}; 188 189SKIP: { 190 use Config; 191 unless ($Config{d_fork}) { 192 skip 'Need a real fork()', 4; 193 } 194 # For coverage: Output from forked-off processes? 195 my $me; 196 trap { 197 trap { 198 $me = fork ? 'parent' : 'child'; 199 print "\u$me print\n"; 200 warn "\u$me warning\n"; 201 trap { 1 }; 202 wait, exit $$ if $me eq 'parent'; 203 }; 204 # On windows, in the child pseudo-process, this dies on leaving 205 # the trap (fd 2 is not availible, because it is open in another 206 # thread). I don't think anything can be done about it. 207 CORE::exit(0) if $me eq 'child'; 208 is( $T->exit, $$, "Trapped the parent exit" ); 209 like( $T->stdout, qr/^(Parent print\nChild print\n|Child print\nParent print\n)/, 'STDOUT from both processes!' ); 210 like( $T->stderr, qr/^(Parent warning\nChild warning\n|Child warning\nParent warning\n)/, 'STDERR from both processes!' ); 211 is_deeply( $T->warn, ["Parent warning\n"], 'Warnings from the parent only' ); 212 }; 213} 214 215exit; 216