#!perl
# -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/11-*.t" -*-
use strict;
use warnings;
use Config;
my $code = '';
my $flags = '';
# Thank you, http://search.cpan.org/src/DAGOLDEN/Class-InsideOut-1.02/t/05_forking.t
# If Win32, fork() is done with threads, so we need various things
if ( $^O =~ /^(?:MSWin32|NetWare|WinCE)\z/ ) {
$code .= <<'COVERAGE';
# don't run this at all under Devel::Cover
if ( $ENV{HARNESS_PERL_SWITCHES} &&
$ENV{HARNESS_PERL_SWITCHES} =~ /Devel::Cover/ ) {
plan skip_all => 'Devel::Cover not compatible with Win32 pseudo-fork';
}
COVERAGE
# skip if threads not available for some reasons
if ( ! $Config{useithreads} ) {
$code .= <<NOTHREADS;
plan skip_all => "Win32 fork() support requires threads";
NOTHREADS
}
# skip if perl < 5.8
if ( $] < 5.008 ) {
$code .= <<NOTHREADS;
plan skip_all => "Win32 fork() support requires perl 5.8";
NOTHREADS
}
}
elsif (!$Config{d_fork}) {
$code .= <<NOFORK;
plan skip_all => 'Fork tests are irrelevant without fork()';
NOFORK
}
else {
$flags = ' -T';
$code .= <<DIAG
BEGIN {
diag('Real fork; taint checks enabled');
}
DIAG
}
(my $file = __FILE__) =~ s/\.PL$/.t/;
open my $fh, '>', $file or die "Cannot open '$file': '$!'";
print $fh "#!perl$flags\n", <<'CODA', $code;
# -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/11-*.t" -*-;
BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile
use Test::More;
use strict;
use warnings;
CODA
print $fh <DATA>;
exit 0;
__DATA__
use File::Temp qw( tempfile );
use Test::Trap::Builder::SystemSafe;
use Test::Trap qw( trap $T :flow:stderr(systemsafe):stdout(systemsafe):warn );
BEGIN {
# silence some warnings that make coverage reports hard to get at
if ($Storable::VERSION) {
eval {
eval { no warnings; Storable::retrieve('.') }; # silly, but hopefully safe ...
my $_r = \&Storable::_retrieve;
no warnings 'redefine';
*Storable::_retrieve = sub {
no warnings;
local $SIG{__WARN__} = sub {};
$_r->(@_);
};
};
}
if ($Devel::Cover::DB::Structure::VERSION) {
eval {
my $d = \&Devel::Cover::DB::Structure::digest;
no warnings 'redefine';
*Devel::Cover::DB::Structure::digest = sub {
no warnings;
local $SIG{__WARN__} = sub {};
$d->(@_);
};
};
}
}
# Protect against tainted PATH &c ...
$ENV{PATH} = '';
$ENV{CDPATH} = '';
$ENV{ENV} = '';
$ENV{BASH_ENV} = '';
my ($PERL) = $^X =~ /^([\w.\/:\\~-]+)$/;
if ($PERL) {
plan tests => 3 + 6*6 + 4;
}
else {
plan skip_all => "Odd perl path: $^X";
}
my $desc = "fdopen()ed file handle";
SKIP: {
skip 'These tests are irrelevant on old perls', 3 if $] < 5.008;
open my $fh, '>&=STDOUT' or die "Cannot fdopen STDOUT: '$!'";
exit diag "Got fileno " . fileno($fh) unless fileno($fh)==1;
# Basic error situation: STDOUT cannot be reopened on fd-1:
eval { trap { system $PERL, '-e', 'binmode STDOUT; binmode STDERR; warn qq(0123456789Warning\n); print qq(Printing\n)'; exit 1 } };
like( $@, qr/^\QCannot get the desired descriptor, '1' (could it be that it is fdopened and so still open?)/, "$desc: exception string" );
is( fileno STDOUT, undef, "$desc: STDOUT should be left closed by now")
or exit diag "Got STDOUT with fd " . fileno(STDOUT);
is( fileno STDERR, 2, "$desc: STDERR fileno should be unchanged");
unless (fileno(STDOUT) or open STDOUT, '>&=' . fileno $fh) {
exit diag "Cannot fdopen fno ".fileno($fh).": '$!'";
}
if (fileno $fh and !close $fh) {
exit diag "Cannot close: '$!'";
}
}
$desc = "simple fork test";
trap {
fork ? wait : do { warn "0123456789Warning\n"; print "Printing\n" };
exit 1;
};
is( $T->exit, 1, "$desc: exit(1)" );
is( $T->stdout, "Printing\n", "$desc: system() STDOUT" );
is( $T->stderr, "0123456789Warning\n", "$desc: system() STDERR" );
is( join("\n", @{$T->warn}), '', "$desc: No warnings" );
# Have the file handles been re-opened on the right descriptors?
is( fileno STDOUT, 1, "$desc: STDOUT fileno should be unchanged");
is( fileno STDERR, 2, "$desc: STDERR fileno should be unchanged");
# Basic messing-up -- protect the handles with an outer trap:
trap {
for (1..5) {
my $desc = "Take $_";
my $OUTFNO = 1;
my $EXPECT = "Printing\n";
if ($_ > 2) {
close STDIN;
$desc .= ' - STDIN closed';
}
if ($_ > 3) {
close STDOUT;
undef $OUTFNO;
$EXPECT = '';
$desc .= ' - STDOUT closed';
}
# Output from forked-off processes?
trap {
my @args = ($PERL, '-e', 'binmode STDOUT; binmode STDERR; warn qq(0123456789Warning\n); print qq(Printing\n)');
system @args and die "system @args failed with $?";
exit 1;
};
is( $T->exit, 1, "$desc: exit(1)" )
or $T->diag_all;
is( $T->stdout, $EXPECT, "$desc: system() STDOUT" );
is( $T->stderr, "0123456789Warning\n", "$desc: system() STDERR" );
is( join("\n", @{$T->warn}), '', "$desc: No warnings" );
# Have the file handles been re-opened on the right descriptors?
is( fileno STDOUT, $OUTFNO, "$desc: STDOUT fileno should be unchanged");
is( fileno STDERR, 2, "$desc: STDERR fileno should be unchanged");
}
};
SKIP: {
use Config;
unless ($Config{d_fork}) {
skip 'Need a real fork()', 4;
}
# For coverage: Output from forked-off processes?
my $me;
trap {
trap {
$me = fork ? 'parent' : 'child';
print "\u$me print\n";
warn "\u$me warning\n";
trap { 1 };
wait, exit $$ if $me eq 'parent';
};
# On windows, in the child pseudo-process, this dies on leaving
# the trap (fd 2 is not availible, because it is open in another
# thread). I don't think anything can be done about it.
CORE::exit(0) if $me eq 'child';
is( $T->exit, $$, "Trapped the parent exit" );
like( $T->stdout, qr/^(Parent print\nChild print\n|Child print\nParent print\n)/, 'STDOUT from both processes!' );
like( $T->stderr, qr/^(Parent warning\nChild warning\n|Child warning\nParent warning\n)/, 'STDERR from both processes!' );
is_deeply( $T->warn, ["Parent warning\n"], 'Warnings from the parent only' );
};
}
exit;