1#!perl -T
2
3BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile
4use Test::More;
5use IO::Handle;
6use File::Temp qw( tempfile );
7use Data::Dump qw(dump);
8use strict;
9use warnings;
10
11our $strategy; # to be set in the requiring test script ...
12our $class; # may be set in the requiring test script, otherwise:
13BEGIN {
14  $class ||= "Test::Trap::Builder::$strategy";
15  local $@;
16  eval qq{ use $class };
17  if (exists &{"$class\::import"}) {
18    plan tests => 1 + 6*10 + 5*3 + 11; # 10 runtests; 3 inner_tests; another bunch ...
19  }
20  else {
21    plan skip_all => "$strategy strategy not supported; skipping";
22  }
23}
24
25# This is an ugly bunch of tests, but for regression's sake, I'll
26# leave it as-is.
27
28# One problem is that warn() (or rather, the default __WARN__ handler)
29# will print on the previous STDERR if the current STDERR is closed.
30
31# Another problem is that the __WARN__ handler has not always been
32# properly restored on exit from a trap.  Ouch.
33
34BEGIN {
35  use_ok( 'Test::Trap', '$T', lc ":flow:stdout($strategy):stderr($strategy):warn" );
36}
37
38STDERR: {
39  close STDERR;
40  my ($errfh, $errname) = tempfile( UNLINK => 1 );
41  open STDERR, '>', $errname;
42  STDERR->autoflush(1);
43  print STDOUT '';
44  sub stderr () { local $/; no warnings 'io'; local *ERR; open ERR, '<', $errname or die; <ERR> }
45  END { close STDERR; close $errfh }
46}
47
48sub diagdie {
49  my $msg = shift;
50  diag $msg;
51  die $msg;
52}
53
54my ($noise, $noisecounter) = ('', 0);
55sub runtests(&@) { # runs the trap and performs 6 tests
56  my($code, $return, $warn, $stdout, $stderr, $desc) = @_;
57  my $n = ++$noisecounter . $/;
58  warn $n or diagdie "Cannot warn()!";
59  STDERR->flush or diagdie "Cannot flush STDERR!";
60  print STDERR $n or diagdie "Cannot print on STDERR!";
61  STDERR->flush or diagdie "Cannot flush STDERR!";
62  $noise .= "$n$n";
63  $warn = do { local $" = "[^`]*`"; qr/\A@$warn[^`]*\z/ };
64  my @r = eval { &trap($code) }; # bypass prototype
65  my $e = $@;
66SKIP: {
67    ok( !$e, "$desc: No internal exception" ) or do {
68      diag "Got internal exception: '$e'";
69      skip "$desc: Internal exception -- bad state", 5;
70    };
71    is_deeply( $T->return, $return, "$desc: Return" );
72    like( join("`", @{$T->warn}), $warn, "$desc: Warnings" );
73    is( $T->stdout, $stdout, "$desc: STDOUT" );
74    like( $T->stderr, $stderr, "$desc: STDERR" );
75    is( stderr, $noise, ' -- no uncaptured STDERR -- ' );
76  }
77}
78
79my $inner_trap;
80sub inner_tests(@) { # performs 5 tests
81  my($return, $warn, $stdout, $stderr, $desc) = @_;
82  $warn = do { local $" = "[^`]*`"; qr/\A@$warn[^`]*\z/ };
83SKIP: {
84    ok(eval{$inner_trap->isa('Test::Trap')}, "$desc: The object" )
85      or skip 'No inner trap object!', 4;
86    is_deeply( $inner_trap->return, $return, "$desc: Return" );
87    like( join("`", @{$inner_trap->warn}), $warn, "$desc: Warnings" );
88    is( $inner_trap->stdout, $stdout, "$desc: STDOUT" );
89    like( $inner_trap->stderr, $stderr, "$desc: STDERR" );
90  }
91  undef $inner_trap; # catch those simple mistakes.
92}
93
94runtests { 5 }
95  [5], [],
96  '', qr/\A\z/,
97  'No output';
98
99runtests { my $t; print "Test printing '$t'"; 2}
100  [2], [ qr/^Use of uninitialized value.* in concatenation \Q(.) or string at / ],
101  "Test printing ''", qr/^Use of uninitialized value.* in concatenation \Q(.) or string at /,
102  'Warning';
103
104runtests { close STDERR; my $t; print "Test printing '$t'"; 2}
105  [2], [ qr/^Use of uninitialized value.* in concatenation \Q(.) or string at / ],
106  "Test printing ''", qr/\A\z/,
107  'Warning with closed STDERR';
108
109runtests { warn "Testing stderr trapping\n"; 5 }
110  [5], [ qr/^Testing stderr trapping$/ ],
111  '', qr/^Testing stderr trapping$/,
112  'warn()';
113
114runtests { close STDERR; warn "Testing stderr trapping\n"; 5 }
115  [5], [ qr/^Testing stderr trapping$/ ],
116  '', qr/\A\z/,
117  'warn() with closed STDERR';
118
119runtests {
120  warn "Outer 1st\n";
121  my @r = trap { warn "Testing stderr trapping\n"; 5 };
122  binmode(STDERR); # XXX: masks a real weakness -- we do not simply restore the original!
123  $inner_trap = $T;
124  warn "Outer 2nd\n";
125  @r
126} [5], [ qr/Outer 1st/, qr/Outer 2nd/ ],
127  '', qr/^Outer 1st\nOuter 2nd$/,
128  'warn() in both traps';
129inner_tests
130  [5], [ qr/^Testing stderr trapping$/ ],
131  '', qr/^Testing stderr trapping$/,
132  ' -- the inner trap -- warn()';
133
134runtests { print STDERR "Test printing"; 2}
135  [2], [],
136  '', qr/^Test printing\z/,
137  'print() on STDERR';
138
139runtests { close STDOUT; print "Testing stdout trapping\n"; 6 }
140  [6], [ qr/^print\Q() on closed filehandle STDOUT at / ],
141  '', qr/^print\Q() on closed filehandle STDOUT at /,
142  'print() with closed STDOUT';
143
144runtests { close STDOUT; my @r = trap { print "Testing stdout trapping\n"; (5,6) }; $inner_trap = $T; @r }
145  [5, 6], [],
146  '', qr/\A\z/,
147  'print() in inner trap with closed STDOUT';
148inner_tests
149  [5, 6], [ qr/^print\Q() on closed filehandle STDOUT at / ],
150  '', qr/^print\Q() on closed filehandle STDOUT at /,
151  ' -- the inner trap -- print() with closed STDOUT';
152
153runtests { close STDERR; my @r = trap { warn "Testing stderr trapping\n"; 2 }; $inner_trap = $T; @r }
154  [2], [],
155  '', qr/\A\z/,
156  'warn() in inner trap with closed STDERR';
157inner_tests
158  [2], [ qr/^Testing stderr trapping$/ ],
159  '', qr/\A\z/,
160  ' -- the inner trap -- warn() with closed STDERR';
161
162# regression test for the ', <$fh> line 1.' bug:
163trap {
164    trap {};
165    warn "no newline";
166};
167unlike $T->stderr, qr/, \S+ line 1\./, 'No "<$f> line ..." stuff, please';
168
169# regression test for preservation of PerlIO layers:
170SKIP: {
171  skip 'Lacking PerlIO', 4 unless eval "use PerlIO; 1";
172  my @io = PerlIO::get_layers(*STDOUT);
173  trap { binmode STDOUT, ':utf8' }; # or whatever, really
174  is_deeply( [PerlIO::get_layers(*STDOUT)], \@io, 'STDOUT still has the original layers.')
175    or diag(dump(\@io));
176  binmode STDOUT;
177  my @raw = PerlIO::get_layers(*STDOUT);
178  trap { binmode STDOUT, ':utf8' }; # or whatever, really
179  is_deeply( [PerlIO::get_layers(*STDOUT)], \@raw, 'STDOUT is still binmoded.')
180    or diag(dump([PerlIO::get_layers(*STDOUT)], \@raw));
181  binmode STDOUT, ':crlf';
182  my @crlf = PerlIO::get_layers(*STDOUT);
183  trap { binmode STDOUT, ':utf8' }; # or whatever, really
184  is_deeply( [PerlIO::get_layers(*STDOUT)], \@crlf, 'STDOUT still has the crlf layer(s).')
185    or diag(dump([PerlIO::get_layers(*STDOUT)], \@crlf));
186  binmode STDOUT;
187  my @tmp = @io;
188  $_ eq $tmp[0] ? shift @tmp : last for PerlIO::get_layers(*STDOUT);
189  binmode STDOUT, $_ for @tmp;
190  is_deeply( [PerlIO::get_layers(*STDOUT)], \@io, 'Sanity check: STDOUT now again has the original layers.')
191    or diag(dump([PerlIO::get_layers(*STDOUT)], \@io));
192}
193
194# test the $! handling:
195my $errnum = 11; # "Resource temporarily unavailable" locally -- sounds good :-P
196my $errstring = do { local $! = $errnum; "$!" };
197my $erros = do { local $! = $errnum; $^E };
198my ($errsym) = do { local $! = $errnum; grep { $!{$_} } keys(%!) };
199{
200  local $! = $errnum;
201  trap {};
202  my ($sym) = grep { $!{$_} } keys(%!);
203  {
204    # rt.cpan.org #105125: Test::More::is() does not preserve $^E, so ...
205    my $postbang = $!+0;
206    my $postos   = $^E;
207    local($!, $^E);
208    is $postbang,$errnum, "$strategy trap doesn't change errno (remains $errnum/$errstring)";
209    is $postos, $erros,  "$strategy trap doesn't change extended OS error (remains $erros)";
210    is $sym,    $errsym, "$strategy trap doesn't change the error symbol (remains $errsym)";
211  }
212}
213
214{
215  local $! = $errnum;
216  trap {
217    $! = 0;
218    $^E = '';
219  };
220  my ($sym) = grep { $!{$_} } keys(%!);
221  {
222    # rt.cpan.org #105125: Test::More::is() does not preserve $^E, so ...
223    my $postbang = $!+0;
224    my $postos   = $^E;
225    local($!, $^E);
226    is $postbang,0, "Errno-unsetting trap unsets errno (it's not localized)";
227    is $postos, '', "Errno-unsetting trap unsets extended OS error (it's not localized)";
228    is $sym, undef, "Errno-unsetting trap unsets the error symbol (it's not localized)";
229  }
230}
231
2321;
233