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