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