File Coverage

inc/Test/Exception.pm
Criterion Covered Total %
statement 52 99 52.5
branch 7 32 21.8
condition 2 9 22.2
subroutine 13 18 72.2
pod 4 4 100.0
total 78 162 48.1


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