File Coverage

inc/Test/Exception.pm
Criterion Covered Total %
statement 49 99 49.4
branch 7 32 21.8
condition 1 9 11.1
subroutine 12 18 66.6
pod 4 4 100.0
total 73 162 45.0


line stmt bran cond sub pod time code
1 1     1   16891 #line 1
  1         4  
  1         42  
2 1     1   6 use strict;
  1         2  
  1         57  
3             use warnings;
4              
5 1     1   8 package Test::Exception;
  1         4  
  1         31  
6 1     1   492 use Test::Builder;
  1         3  
  1         7  
7 1     1   7 use Sub::Uplevel qw( uplevel );
  1         2  
  1         379  
8             use base qw( Exporter );
9              
10             our $VERSION = '0.43';
11             $VERSION = eval $VERSION;
12              
13             our @EXPORT = qw(dies_ok lives_ok throws_ok lives_and);
14              
15             my $Tester = Test::Builder->new;
16              
17 1     1   11 sub import {
18 1 50       6 my $self = shift;
19 0         0 if ( @_ ) {
20 0         0 my $package = caller;
21 0         0 $Tester->exported_to( $package );
22             $Tester->plan( @_ );
23 1         245 };
24             $self->export_to_level( 1, $self, $_ ) foreach @EXPORT;
25             }
26              
27             #line 90
28              
29             sub _quiet_caller (;$) { ## no critic Prototypes
30             my $height = $_[0];
31             $height++;
32              
33             if ( CORE::caller() eq 'DB' ) {
34             # passthrough the @DB::args trick
35             package DB;
36             if( wantarray ) {
37             if ( !@_ ) {
38             return (CORE::caller($height))[0..2];
39             }
40             else {
41             # If we got here, we are within a Test::Exception test, and
42             # something is producing a stacktrace. In case this is a full
43             # trace (i.e. confess() ), we have to make sure that the sub
44             # args are not visible. If we do not do this, and the test in
45             # question is throws_ok() with a regex, it will end up matching
46             # against itself in the args to throws_ok().
47             #
48             # While it is possible (and maybe wise), to test if we are
49             # indeed running under throws_ok (by crawling the stack right
50             # up from here), the old behavior of Test::Exception was to
51             # simply obliterate @DB::args altogether in _quiet_caller, so
52             # we are just preserving the behavior to avoid surprises
53             #
54             my @frame_info = CORE::caller($height);
55             @DB::args = ();
56             return @frame_info;
57             }
58             }
59              
60             # fallback if nothing above returns
61             return CORE::caller($height);
62             }
63             else {
64             if( wantarray and !@_ ) {
65             return (CORE::caller($height))[0..2];
66             }
67             else {
68             return CORE::caller($height);
69             }
70             }
71             }
72              
73             sub _try_as_caller {
74             my $coderef = shift;
75              
76             # local works here because Sub::Uplevel has already overridden caller
77             local *CORE::GLOBAL::caller;
78             { no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; }
79              
80             eval { uplevel 3, $coderef };
81             return $@;
82             };
83              
84              
85             sub _is_exception {
86             my $exception = shift;
87             return ref $exception || $exception ne '';
88             };
89              
90              
91             sub _exception_as_string {
92 1     1   4 my ( $prefix, $exception ) = @_;
93 1         4 return "$prefix normal exit" unless _is_exception( $exception );
94             my $class = ref $exception;
95 1 50       7 $exception = "$class ($exception)"
96             if $class && "$exception" !~ m/^\Q$class/;
97             chomp $exception;
98 0 0       0 return "$prefix $exception";
99 0 0       0 };
100 0         0  
101              
102             #line 213
103              
104              
105             sub throws_ok (&$;$) {
106             my ( $coderef, $expecting, $description ) = @_;
107             unless (defined $expecting) {
108             require Carp;
109             Carp::croak( "throws_ok: must pass exception class/object or regex" );
110             }
111             $description = _exception_as_string( "threw", $expecting )
112             unless defined $description;
113             my $exception = _try_as_caller( $coderef );
114             my $regex = $Tester->maybe_regex( $expecting );
115             my $ok = $regex
116 0         0 ? ( $exception =~ m/$regex/ )
117 0         0 : eval {
118 0         0 $exception->isa( ref $expecting ? ref $expecting : $expecting )
119             };
120             $Tester->ok( $ok, $description );
121             unless ( $ok ) {
122             $Tester->diag( _exception_as_string( "expecting:", $expecting ) );
123 0         0 $Tester->diag( _exception_as_string( "found:", $exception ) );
124             };
125             $@ = $exception;
126 1 50 33     12 return $ok;
127 0         0 };
128              
129              
130 1         15 #line 261
131              
132             sub dies_ok (&;$) {
133             my ( $coderef, $description ) = @_;
134             my $exception = _try_as_caller( $coderef );
135             my $ok = $Tester->ok( _is_exception($exception), $description );
136 4     4   12 $@ = $exception;
137             return $ok;
138             }
139 4         19  
140 1     1   7  
  1         2  
  1         650  
  4         12  
  4         20  
141             #line 300
142 4         15  
  4         26  
143 4         88 sub lives_ok (&;$) {
144             my ( $coderef, $description ) = @_;
145             my $exception = _try_as_caller( $coderef );
146             my $ok = $Tester->ok( ! _is_exception( $exception ), $description );
147             $Tester->diag( _exception_as_string( "died:", $exception ) ) unless $ok;
148 0     0   0 $@ = $exception;
149 0   0     0 return $ok;
150             }
151              
152              
153             #line 340
154 0     0   0  
155 0 0       0 sub lives_and (&;$) {
156 0         0 my ( $test, $description ) = @_;
157 0 0 0     0 {
158             my $ok = \&Test::Builder::ok;
159 0         0 no warnings;
160 0         0 local *Test::Builder::ok = sub {
161             local $Test::Builder::Level = $Test::Builder::Level + 1;
162             $_[2] = $description unless defined $_[2];
163             $ok->(@_);
164             };
165             use warnings;
166             eval { $test->() } and return 1;
167             };
168             my $exception = $@;
169             if ( _is_exception( $exception ) ) {
170             $Tester->ok( 0, $description );
171             $Tester->diag( _exception_as_string( "died:", $exception ) );
172             };
173             $@ = $exception;
174             return;
175             }
176              
177             #line 513
178              
179             1;