File: 08-fork.PL

package info (click to toggle)
libtest-trap-perl 0.2.2-1
  • links: PTS, VCS
  • area: main
  • in suites: wheezy
  • size: 256 kB
  • sloc: perl: 2,258; makefile: 2
file content (153 lines) | stat: -rw-r--r-- 4,003 bytes parent folder | download | duplicates (6)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
#!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;