#!perl
# -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/08-*.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/08-*.t" -*-;
BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile
use Test::More tests => 15;
use strict;
use warnings;
CODA
print $fh <DATA>;
exit 0;
__DATA__
my $flag;
BEGIN {
*CORE::GLOBAL::exit = sub(;$) {
if ($flag) {
pass("The final test: The outer CORE::GLOBAL::exit is eventually called");
}
else {
fail("The outer CORE::GLOBAL::exit is called too soon!");
}
CORE::exit(@_ ? shift : 0);
};
}
BEGIN {
use_ok( 'Test::Trap' );
}
# check that the setup works -- the exit is still trapped:
trap { exit };
is( $trap->exit, 0, "Trapped the first exit");
# check that the exit from the forked-off process reverts to the inner
# CORE::GLOBAL::exit, not the outer
trap {
*CORE::GLOBAL::exit = sub(;$) {
pass("The inner CORE::GLOBAL::exit is called from the child");
CORE::exit(@_ ? shift : 0);
};
trap {
fork;
exit;
};
wait; # let the child finish first
# Increment the counter correctly ...
my $Test = Test::More->builder;
$Test->current_test( $Test->current_test + 1 );
is( $trap->exit, 0, "Trapped the inner exit");
};
like( $trap->stderr, qr/^Subroutine (?:CORE::GLOBAL::)?exit \Qredefined at ${\__FILE__} line/, 'Override warning' );
trap {
trap{
trap {
fork;
exit;
};
wait;
is( $trap->exit, 0, "Trapped the inner exit" );
}
};
is( $trap->leaveby, 'return', 'Should return just once, okay?' );
# Output from forked-off processes?
my $me;
trap {
$me = fork ? 'parent' : 'child';
print "\u$me print\n";
warn "\u$me warning\n";
wait, exit $$ if $me eq 'parent';
};
CORE::exit(0) if $me eq 'child';
is( $trap->exit, $$, "Trapped the parent exit" );
like( $trap->stdout, qr/^(Parent print\nChild print\n|Child print\nParent print\n)/, 'STDOUT from both processes!' );
like( $trap->stderr, qr/^(Parent warning\nChild warning\n|Child warning\nParent warning\n)/, 'STDERR from both processes!' );
is_deeply( $trap->warn, ["Parent warning\n"], 'Warnings from the parent only' );
# STDERR from forked-off processes, with a closed STDIN & STDOUT?
trap {
close STDOUT;
trap {
my $me = fork ? 'parent' : 'child';
print "\u$me print\n";
warn "\u$me warning\n";
wait, exit $$ if $me eq 'parent';
CORE::exit(0);
};
is( $trap->exit, $$, "Trapped the parent exit" );
is( $trap->stdout, '', 'STDOUT from both processes is nil -- the handle is closed!' );
like( $trap->stderr, qr/\A(?=.*^Parent warning$)(?=.*^Child warning$)/ms, 'STDERR from both processes!' );
};
$flag++; # the exit test will now pass -- in the forked-off processes it will fail!
exit;