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
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
|
#!perl -T
BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile
use Test::More;
use IO::Handle;
use File::Temp qw( tempfile );
use Data::Dump qw(dump);
use strict;
use warnings;
our $backend; # to be set in the requiring test script ...
BEGIN {
my $pkg = "Test::Trap::Builder::$backend";
local $@;
eval qq{ use $pkg };
if (exists &{"$pkg\::import"}) {
plan tests => 1 + 6*10 + 5*3 + 1; # 10 runtests; 3 inner_tests
}
else {
plan skip_all => "$backend backend not supported; skipping";
}
}
# This is an ugly bunch of tests, but for regression's sake, I'll
# leave it as-is.
# One problem is that warn() (or rather, the default __WARN__ handler)
# will print on the previous STDERR if the current STDERR is closed.
# Another problem is that the __WARN__ handler has not always been
# properly restored on exit from a trap. Ouch.
BEGIN {
use_ok( 'Test::Trap', '$T', lc ":flow:stdout($backend):stderr($backend):warn" );
}
STDERR: {
close STDERR;
my ($errfh, $errname) = tempfile( UNLINK => 1 );
open STDERR, '>', $errname;
STDERR->autoflush(1);
print STDOUT '';
sub stderr () { local $/; no warnings 'io'; local *ERR; open ERR, '<', $errname or die; <ERR> }
END { close STDERR; close $errfh }
}
sub diagdie {
my $msg = shift;
diag $msg;
die $msg;
}
my ($noise, $noisecounter) = ('', 0);
sub runtests(&@) { # runs the trap and performs 6 tests
my($code, $return, $warn, $stdout, $stderr, $desc) = @_;
my $n = ++$noisecounter . $/;
warn $n or diagdie "Cannot warn()!";
STDERR->flush or diagdie "Cannot flush STDERR!";
print STDERR $n or diagdie "Cannot print on STDERR!";
STDERR->flush or diagdie "Cannot flush STDERR!";
$noise .= "$n$n";
$warn = do { local $" = "[^`]*`"; qr/\A@$warn[^`]*\z/ };
my @r = eval { &trap($code) }; # bypass prototype
my $e = $@;
SKIP: {
ok( !$e, "$desc: No internal exception" ) or do {
diag "Got internal exception: '$e'";
skip "$desc: Internal exception -- bad state", 5;
};
is_deeply( $T->return, $return, "$desc: Return" );
like( join("`", @{$T->warn}), $warn, "$desc: Warnings" );
is( $T->stdout, $stdout, "$desc: STDOUT" );
like( $T->stderr, $stderr, "$desc: STDERR" );
is( stderr, $noise, ' -- no uncaptured STDERR -- ' );
}
}
my $inner_trap;
sub inner_tests(@) { # performs 5 tests
my($return, $warn, $stdout, $stderr, $desc) = @_;
$warn = do { local $" = "[^`]*`"; qr/\A@$warn[^`]*\z/ };
SKIP: {
ok(eval{$inner_trap->isa('Test::Trap')}, "$desc: The object" )
or skip 'No inner trap object!', 4;
is_deeply( $inner_trap->return, $return, "$desc: Return" );
like( join("`", @{$inner_trap->warn}), $warn, "$desc: Warnings" );
is( $inner_trap->stdout, $stdout, "$desc: STDOUT" );
like( $inner_trap->stderr, $stderr, "$desc: STDERR" );
}
undef $inner_trap; # catch those simple mistakes.
}
runtests { 5 }
[5], [],
'', qr/\A\z/,
'No output';
runtests { my $t; print "Test printing '$t'"; 2}
[2], [ qr/^Use of uninitialized value.* in concatenation \Q(.) or string at / ],
"Test printing ''", qr/^Use of uninitialized value.* in concatenation \Q(.) or string at /,
'Warning';
runtests { close STDERR; my $t; print "Test printing '$t'"; 2}
[2], [ qr/^Use of uninitialized value.* in concatenation \Q(.) or string at / ],
"Test printing ''", qr/\A\z/,
'Warning with closed STDERR';
runtests { warn "Testing stderr trapping\n"; 5 }
[5], [ qr/^Testing stderr trapping$/ ],
'', qr/^Testing stderr trapping$/,
'warn()';
runtests { close STDERR; warn "Testing stderr trapping\n"; 5 }
[5], [ qr/^Testing stderr trapping$/ ],
'', qr/\A\z/,
'warn() with closed STDERR';
runtests {
warn "Outer 1st\n";
my @r = trap { warn "Testing stderr trapping\n"; 5 };
binmode(STDERR); # XXX: masks a real weakness -- we do not simply restore the original!
$inner_trap = $T;
warn "Outer 2nd\n";
@r
} [5], [ qr/Outer 1st/, qr/Outer 2nd/ ],
'', qr/^Outer 1st\nOuter 2nd$/,
'warn() in both traps';
inner_tests
[5], [ qr/^Testing stderr trapping$/ ],
'', qr/^Testing stderr trapping$/,
' -- the inner trap -- warn()';
runtests { print STDERR "Test printing"; 2}
[2], [],
'', qr/^Test printing\z/,
'print() on STDERR';
runtests { close STDOUT; print "Testing stdout trapping\n"; 6 }
[6], [ qr/^print\Q() on closed filehandle STDOUT at / ],
'', qr/^print\Q() on closed filehandle STDOUT at /,
'print() with closed STDOUT';
runtests { close STDOUT; my @r = trap { print "Testing stdout trapping\n"; (5,6) }; $inner_trap = $T; @r }
[5, 6], [],
'', qr/\A\z/,
'print() in inner trap with closed STDOUT';
inner_tests
[5, 6], [ qr/^print\Q() on closed filehandle STDOUT at / ],
'', qr/^print\Q() on closed filehandle STDOUT at /,
' -- the inner trap -- print() with closed STDOUT';
runtests { close STDERR; my @r = trap { warn "Testing stderr trapping\n"; 2 }; $inner_trap = $T; @r }
[2], [],
'', qr/\A\z/,
'warn() in inner trap with closed STDERR';
inner_tests
[2], [ qr/^Testing stderr trapping$/ ],
'', qr/\A\z/,
' -- the inner trap -- warn() with closed STDERR';
# regression test for the ', <$fh> line 1.' bug:
trap {
trap {};
warn "no newline";
};
unlike $T->stderr, qr/, \S+ line 1\./, 'No "<$f> line ..." stuff, please';
1;
|
