File Coverage

blib/lib/Test/Trap.pm
Criterion Covered Total %
statement 96 96 100.0
branch 28 28 100.0
condition n/a
subroutine 26 26 100.0
pod 3 3 100.0
total 153 153 100.0


line stmt bran cond sub pod time code
1             package Test::Trap;
2              
3 27     27   1081613 use version; $VERSION = qv('0.3.3');
  27         30179  
  27         211  
4              
5 27     27   2854 use strict;
  27         73  
  27         744  
6 27     27   178 use warnings;
  27         73  
  27         1053  
7 27     27   187 use Carp qw( croak );
  27         65  
  27         2083  
8 27     27   6141 use Data::Dump qw(dump);
  27         111750  
  27         2077  
9 27     27   7889 use Test::Trap::Builder qw( :methods );
  27         99  
  27         12822  
10              
11             my $B = Test::Trap::Builder->new;
12              
13             sub import {
14 66     66   14285 my $trapper = shift;
15 66         249 my $callpkg = caller;
16 66         195 my (@function, @scalar, @layer);
17 66         311 while (@_) {
18 145         382 my $sym = shift;
19 145 100       2031 UNIVERSAL::isa($sym, 'CODE') ? push @layer, $sym :
    100          
    100          
    100          
20             $sym =~ s/^:// ? push @layer, split/:/, $sym :
21             $sym =~ s/^\$// ? push @scalar, $sym :
22             $sym !~ m/^[@%*]/ ? push @function, $sym :
23             croak qq["$sym" is not exported by the $trapper module];
24             }
25 65 100       329 if (@function > 1) {
26 1         183 croak qq[The $trapper module does not export more than one function];
27             }
28 64 100       271 if (@scalar > 1) {
29 1         134 croak qq[The $trapper module does not export more than one scalar];
30             }
31 63 100       280 my $function = @function ? $function[0] : 'trap';
32 63 100       314 my $scalar = @scalar ? $scalar[0] : 'trap';
33 63         392 @layer = $B->layer_implementation($trapper, default => @layer);
34 27     27   243 no strict 'refs';
  27         81  
  27         8847  
35 61         163 my $gref = \*{"$callpkg\::$scalar"};
  61         432  
36 61         195 *$gref = \ do { my $x = bless {}, $trapper };
  61         353  
37 61         13190 *{"$callpkg\::$function"} = sub (&) {
38 320     320   367613 $B->trap($trapper, $gref, \@layer, shift);
39             }
40 61         449 }
41              
42             ####################
43             # Standard layers #
44             ####################
45              
46             # The big one: trapping exits correctly:
47             EXIT_LAYER: {
48             # A versatile &CORE::GLOBAL::exit candidate:
49             sub _global_exit (;$) {
50 58 100   58   5108274 my $exit = @_ ? 0+shift : 0;
51 58 100       867 ___exit($exit) if exists &___exit;
52 3         192 CORE::exit($exit);
53             };
54              
55             # Need to have &CORE::GLOBAL::exit set, one way or the other,
56             # before any code to be trapped is compiled:
57             *CORE::GLOBAL::exit = \&_global_exit unless exists &CORE::GLOBAL::exit;
58              
59             # And at last, the layer for exits:
60             $B->layer(exit => $_) for sub {
61             my $self = shift;
62             # in case someone else is messing with exit:
63             my $pid = $$;
64             my $outer = \&CORE::GLOBAL::exit;
65             undef $outer if $outer == \&_global_exit;
66             local *___exit;
67             TEST_TRAP_EXITING: {
68             {
69 27     27   246 no warnings 'redefine';
  27         72  
  27         2893  
70             *___exit = sub {
71             if ($$ != $pid) {
72             return $outer->(@_) if $outer;
73             # XXX: This is fuzzy ... how to test this right?
74             CORE::exit(shift);
75             }
76             $self->{exit} = shift;
77             $self->{leaveby} = 'exit';
78 27     27   213 no warnings 'exiting';
  27         70  
  27         9008  
79             last TEST_TRAP_EXITING;
80             };
81             }
82             local *CORE::GLOBAL::exit;
83             *CORE::GLOBAL::exit = \&_global_exit;
84             $self->Next;
85             }
86             return;
87             };
88             }
89              
90             # The other layers and standard accessors:
91              
92             # Note: :raw is a terminating layer -- it does not call any lower
93             # layer, but is the layer responsible for calling the actual code!
94             $B->layer(raw => $_) for sub {
95             my $self = shift;
96             my $wantarray = $self->{wantarray};
97             my @return;
98             unless (defined $wantarray) { $self->Run }
99             elsif ($wantarray) { @return = $self->Run }
100             else { @return = scalar $self->Run }
101             $self->{return} = \@return;
102             $self->{leaveby} = 'return';
103             };
104              
105             # A simple layer for exceptions:
106             $B->layer(die => $_) for sub {
107             my $self = shift;
108             local *@;
109             return if eval { $self->Next; 1 };
110             $self->{die} = $@;
111             $self->{leaveby} = 'die';
112             };
113              
114             # Layers for STDOUT and STDERR, from the factory:
115             $B->output_layer( stdout => \*STDOUT );
116             $B->output_layer( stderr => \*STDERR );
117             BEGIN {
118             # Make available some capture strategies:
119 27     27   10072 use Test::Trap::Builder::TempFile;
  27         103  
  27         145  
120 27     27   232 use Test::Trap::Builder::TempFile 'tempfile-preserve' => { preserve_io_layers => 1 };
  27         89  
  27         165  
121             # optional capture strategies:
122 27     27   1946 eval q{ use Test::Trap::Builder::PerlIO };
  27     27   9638  
  27         141  
  27         203  
123 27     27   1823 eval q{ use Test::Trap::Builder::SystemSafe };
  27         7233  
  27         112  
  27         184  
124 27     27   2021 eval q{ use Test::Trap::Builder::SystemSafe 'systemsafe-preserve' => { preserve_io_layers => 1 } };
  27         238  
  27         76  
  27         185  
125             }
126              
127             # A simple layer for warnings:
128             $B->layer(warn => $_) for sub {
129             my $self = shift;
130             my @warn;
131             # Can't local($SIG{__WARN__}) because of a perl bug with local() on
132             # scalar values under the Windows fork() emulation -- work around:
133             my $sigwarn = $SIG{__WARN__};
134             my $sigwarn_exists = exists $SIG{__WARN__};
135             $SIG{__WARN__} = sub {
136             my $w = shift;
137             push @warn, $w;
138             print STDERR $w if defined fileno STDERR;
139             };
140             $self->Teardown($_) for sub {
141             if ($sigwarn_exists) {
142             $SIG{__WARN__} = $sigwarn;
143             }
144             else {
145             delete $SIG{__WARN__};
146             }
147             };
148             $self->{warn} = \@warn;
149             $self->Next;
150             };
151              
152             # Multi-layers:
153             $B->multi_layer(flow => qw/ raw die exit /);
154             $B->multi_layer(default => qw/ flow stdout stderr warn /);
155              
156             # Non-default non-trapping layers:
157             $B->layer( void => $_ ) for sub {
158             my $self = shift;
159             undef $self->{wantarray};
160             $self->Next;
161             };
162             $B->layer( scalar => $_ ) for sub {
163             my $self = shift;
164             $self->{wantarray} = '';
165             $self->Next;
166             };
167             $B->layer( list => $_ ) for sub {
168             my $self = shift;
169             $self->{wantarray} = 1;
170             $self->Next;
171             };
172             $B->layer( on_fail => $_ ) for sub {
173             my $self = shift;
174             my ($arg) = @_;
175             $self->Prop('Test::Trap::Builder')->{on_test_failure} = $arg;
176             $self->Next;
177             };
178             $B->layer( output => $_ ) for sub {
179             my $self = shift;
180             my $strategy = eval { $B->first_capture_strategy(@_) };
181             $self->Exception($@) if $@;
182             $self->Prop('Test::Trap::Builder')->{capture_strategy} = $strategy;
183             $self->Next;
184             };
185              
186             ########################
187             # Standard accessors #
188             ########################
189              
190             $B->accessor( simple => [ qw/ leaveby stdout stderr wantarray / ],
191             flexible =>
192             { list => sub {
193 15     15   163 $_[0]{wantarray};
194             },
195             scalar => sub {
196 15     15   55 my $x = $_[0]{wantarray};
197 15 100       147 !$x and defined $x;
198             },
199             void => sub {
200 15     15   106 not defined $_[0]{wantarray};
201             },
202             },
203             );
204             $B->accessor( is_leaveby => 1,
205             simple => [ qw/ exit die / ],
206             );
207             $B->accessor( is_array => 1,
208             simple => [ qw/ warn / ],
209             );
210             $B->accessor( is_array => 1,
211             is_leaveby => 1,
212             simple => [ qw/ return / ],
213             );
214              
215             ####################
216             # Standard tests #
217             ####################
218              
219             # This helper and similar strategies below delay loading Test::More
220             # until we actually use this stuff, so that It Just Works if we:
221             # 0) have already loaded and planned with Test::More ;-)
222             # 1) have already loaded and planned with some other Test::Builder module
223             # 2) aren't actually testing, just trapping
224             sub _test_more($) {
225 162     162   503 my $sym = shift;
226             sub {
227 106     106   734 require Test::More;
228 106         219 goto &{"Test::More::$sym"};
  106         742  
229 162         1177 };
230             }
231              
232             for my $simple (qw/ is isnt like unlike isa_ok /) {
233             $B->test( $simple => 'element, predicate, name', _test_more $simple );
234             }
235              
236             $B->test( is_deeply => 'entirety, predicate, name', _test_more 'is_deeply' );
237              
238             $B->test( ok => 'trap, element, name', $_ ) for sub {
239             my $self = shift;
240             my ($got, $name) = @_;
241             require Test::More;
242             my $Test = Test::More->builder;
243             my $ok = $Test->ok( $got, $name );
244             $Test->diag(sprintf<TestAccessor, dump($got)) unless $ok;
245             Expecting true value in %s, but got %s instead
246             OK
247             return $ok;
248             };
249              
250             $B->test( nok => 'trap, element, name', $_ ) for sub {
251             my $self = shift;
252             my ($got, $name) = @_;
253             require Test::More;
254             my $Test = Test::More->builder;
255             my $ok = $Test->ok( !$got, $name );
256             $Test->diag(sprintf<TestAccessor, dump($got)) unless $ok;
257             Expecting false value in %s, but got %s instead
258             NOK
259             return $ok;
260             };
261              
262             # Extra convenience test method:
263             sub quiet {
264 49     49 1 2893 my $self = shift;
265 49         138 my ($name) = @_;
266 49         114 my @fail;
267 49         128 for my $m (qw/stdout stderr/) {
268 98         1094 my $buf = $self->$m . ''; # coerce to string
269 98 100       531 push @fail, "Expecting no \U$m\E, but got " . dump($buf) if $buf ne '';
270             }
271 49         802 require Test::More;
272 49         245 my $Test = Test::More->builder;
273 49 100       683 my $ok = $Test->ok(!@fail, $name) or do {
274 3         3049 $Test->diag(join"\n", @fail);
275 3         1196 $self->TestFailure;
276             };
277 49         28596 $ok;
278             }
279              
280             #####################
281             # Utility methods #
282             #####################
283              
284             sub diag_all {
285 2     2 1 8 my $self = shift;
286 2         18 require Test::More;
287 2         13 Test::More::diag( dump $self );
288             }
289              
290             sub diag_all_once {
291 3     3 1 12 my $self = shift;
292 3 100       15 my $msg = $self->Prop->{diag_all_once}++ ? '(as above)' : dump $self;
293 3         3434 require Test::More;
294 3         23 Test::More::diag( $msg );
295             }
296              
297             1; # End of Test::Trap
298              
299             __END__