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