1#!perl -T 2# -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/07-*.t" -*- 3 4BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile 5use Test::More tests => 8 + 5*18; 6use strict; 7use warnings; 8 9use Test::Trap::Builder; 10my $Builder; BEGIN { $Builder = Test::Trap::Builder->new } 11 12local @ARGV; # in case some harness wants to mess with it ... 13my @argv = ('A'); 14BEGIN { 15 package TT::A; 16 use base 'Test::Trap'; 17 $Builder->layer( argv => $_ ) for sub { 18 my $self = shift; 19 local *ARGV = \@argv; 20 $self->{inargv} = [@argv]; 21 $self->Next; 22 $self->{outargv} = [@argv]; 23 }; 24 $Builder->accessor( is_array => 1, simple => [qw/inargv outargv/] ); 25 $Builder->accessor( flexible => 26 { argv => sub { 27 $_[1] && $_[1] !~ /in/i ? $_[0]{outargv} : $_[0]{inargv}; 28 }, 29 }, 30 ); 31 $Builder->test( can => 'element, predicate, name', $_ ) for sub { 32 my ($got, $methods) = @_; 33 @_ = ($got, @$methods); 34 goto &Test::More::can_ok; 35 }; 36 # Hack! Make perl think we have successfully required this package, 37 # so that we can "use" it, even though it can't be found: 38 $INC{'TT/A.pm'} = 'Hack!'; 39} 40 41BEGIN { 42 package TT::B; 43 use base 'Test::Trap'; 44 $Builder->accessor( flexible => 45 { leavewith => sub { 46 my $self = shift; 47 my $leaveby = $self->leaveby; 48 $self->$leaveby; 49 }, 50 }, 51 ); 52 # Hack! Make perl think we have successfully required this package, 53 # so that we can "use" it, even though it can't be found: 54 $INC{'TT/B.pm'} = 'Hack!'; 55} 56 57BEGIN { 58 package TT::AB; 59 use base qw( TT::A TT::B ); 60 $Builder->test( fail => 'name', \&Test::More::fail ); 61 # Hack! Make perl think we have successfully required this package, 62 # so that we can "use" it, even though it can't be found: 63 $INC{'TT/AB.pm'} = 'Hack!'; 64} 65 66BEGIN { 67 package TT::A2; 68 use base qw( TT::A ); 69 $Builder->test( anotherfail => 'name', \&Test::More::fail ); 70 $Builder->accessor( flexible => 71 { anotherouterr => sub { 72 my $self = shift; 73 $self->stdout . $self->stderr; 74 }, 75 }, 76 ); 77 # Hack! Make perl think we have successfully required this package, 78 # so that we can "use" it, even though it can't be found: 79 $INC{'TT/A2.pm'} = 'Hack!'; 80} 81 82BEGIN { 83 # Insert s'mores into Test::Trap itself ... not clean, but a nice 84 # quick thing to be able to do, in need: 85 package Test::Trap; 86 $Builder->test( pass => 'name', \&Test::More::pass ); 87 $Builder->accessor( flexible => 88 { outerr => sub { 89 my $self = shift; 90 $self->stdout . $self->stderr; 91 }, 92 }, 93 ); 94} 95 96BEGIN { 97 use_ok( 'Test::Trap' ); # import a standard trap/$trap 98 use_ok( 'Test::Trap', '$D', 'D' ); 99 use_ok( 'TT::A', '$A', 'A', ':argv' ); 100 use_ok( 'TT::B', '$B', 'B' ); 101 use_ok( 'TT::AB', '$AB', 'AB', ':argv' ); 102 use_ok( 'TT::A2', '$A2', 'A2', ':argv' ); 103} 104 105BEGIN { 106 trap { 107 package TT::badclass; 108 use base 'Test::Trap'; 109 $Builder->multi_layer( trouble => qw( warn no_such_layer ) ); 110 }; 111 like( $trap->die, 112 qr/^\QUnknown trap layer "no_such_layer" at ${\__FILE__} line/, 113 'Bad definition: unknown layer', 114 ); 115} 116 117BEGIN { 118 trap { 119 package TT::badclass3; 120 use base 'Test::Trap'; 121 $Builder->test( pass => 'named', \&Test::More::pass ); 122 }; 123 like( $trap->die, 124 qr/^\QUnrecognized identifier named in argspec at ${\__FILE__} line/, 125 'Bad definition: test argspec typo ("named" for "name")', 126 ); 127} 128 129basic( \&D, \$D, 'Unmodified Test::Trap', 130 qw( isno_A isno_B isno_AB ), 131 ); 132 133basic( \&A, \$A, 'TT::A', 134 qw( isan_A isno_B isno_AB ), 135 ); 136 137basic( \&B, \$B, 'TT::B', 138 qw( isno_A isa_B isno_AB ), 139 ); 140 141basic( \&AB, \$AB, 'TT::AB', 142 qw( isan_A isa_B isan_AB ), 143 ); 144 145basic( \&A2, \$A2, 'TT::A2', 146 qw( isan_A isno_B isno_AB ), 147 ); 148 149exit 0; 150 151# compile this after the CORE::GLOBAL::exit has been set: 152 153my $argv_expected; 154my $ARGV_expected; 155 156sub isno_A { 157 my ($func, $handle, $name) = @_; 158 ok( !exists $$handle->{inargv}, "$name: no inargv internally" ); 159 push @$ARGV_expected, $name; 160 ok( !exists $$handle->{outargv}, "$name: no outargv internally" ); 161 is_deeply( \@ARGV, $ARGV_expected, "$name: \@ARGV modified" ); 162 is_deeply( \@argv, $argv_expected, "$name: \@argv unmofied" ); 163 ok( !$$handle->can('return_can'), "$name: no return_can method" ); 164 ok( !$$handle->can('outargv'), "$name: no outargv method" ); 165 ok( !$$handle->can('outargv_can'), "$name: no outargv_can method" ); 166 ok( !$$handle->can('outargv_pass'), "$name: no outargv_pass method" ); 167} 168 169sub isan_A { 170 my ($func, $handle, $name) = @_; 171 is_deeply( $$handle->{inargv}, $argv_expected, "$name: inargv present internally" ); 172 push @$argv_expected, $name; 173 is_deeply( $$handle->{outargv}, $argv_expected, "$name: outargv present internally" ); 174 is_deeply( \@ARGV, $ARGV_expected, "$name: \@ARGV unmodified" ); 175 is_deeply( \@argv, $argv_expected, "$name: \@argv modified" ); 176 ok( $$handle->can('return_can'), "$name: return_can method present" ); 177 () = trap { $$handle->outargv }; 178 $trap->return_is_deeply( [$argv_expected], "$name: outargv method present and functional" ); 179 ok( $$handle->can('outargv_can'), "$name: outargv_can method present" ); 180 ok( $$handle->can('outargv_pass'), "$name: outargv_pass method present" ); 181} 182 183sub isa_B { 184 my ($func, $handle, $name) = @_; 185 () = trap { $$handle->leavewith }; 186 $trap->return_is_deeply( [1], "$name: leavewith method present and functional" ); 187} 188 189sub isno_B { 190 my ($func, $handle, $name) = @_; 191 ok( !$$handle->can('leavewith'), "$name: no leavewith method" ); 192} 193 194sub isan_AB { 195 my ($func, $handle, $name) = @_; 196 ok( $$handle->can('stderr_fail'), "$name: stderr_fail method present" ); 197 ok( $$handle->can('argv_fail'), "$name: argv_fail method present" ); 198 ok( $$handle->can('leavewith_fail'), "$name: leavewith_fail method present" ); 199TODO: { 200 local $TODO = 'Multiple inheritance still incomplete'; 201 ok( $$handle->can('leavewith_can'), "$name: leavewith_fail method present" ); 202 } 203} 204 205sub isno_AB { 206 my ($func, $handle, $name) = @_; 207 ok( !$$handle->can('stderr_fail'), "$name: no stderr_fail method" ); 208 ok( !$$handle->can('argv_fail'), "$name: no argv_fail method" ); 209 ok( !$$handle->can('leavewith_fail'), "$name: no leavewith_fail method" ); 210 ok( !$$handle->can('leavewith_can'), "$name: no leavewith_can method" ); 211} 212 213sub basic { 214 my ($func, $handle, $name) = @_; 215 $argv_expected ||= ['A']; 216 $ARGV_expected ||= []; 217 $func->(sub { print "Hello"; warn "Hi!\n"; push @ARGV, $name; exit 1 }); 218 local $Test::Builder::Level = $Test::Builder::Level + 1; 219 is( $$handle->exit, 1, "$name: trapped exit" ); 220 is( $$handle->stdout, "Hello", "$name: trapped stdout" ); 221 is( $$handle->stderr, "Hi!\n", "$name: trapped stderr" ); 222 is_deeply( $$handle->warn, ["Hi!\n"], "$name: trapped warnings" ); 223 ok( $$handle->can('stdout_pass'), "$name: stdout_pass method present" ); 224 $Test::Builder::Level++; 225 no strict 'refs'; 226 $_->(@_) for @_[3..$#_]; 227} 228