File Coverage

inc/Test/Exception.pm
Criterion Covered Total %
statement 59 92 64.1
branch 8 26 30.7
condition 3 9 33.3
subroutine 15 19 78.9
pod 4 4 100.0
total 89 150 59.3


line stmt bran cond sub pod time code
1 1     1   2511 #line 1
  1         4  
  1         52  
2 1     1   6 use strict;
  1         2  
  1         46  
3             use warnings;
4              
5 1     1   6 package Test::Exception;
  1         2  
  1         27  
6 1     1   984 use Test::Builder;
  1         1936  
  1         9  
7 1     1   62 use Sub::Uplevel qw( uplevel );
  1         2  
  1         144  
8 1     1   7 use base qw( Exporter );
  1         3  
  1         1562  
9             use Carp;
10              
11             our $VERSION = '0.27';
12             our @EXPORT = qw(dies_ok lives_ok throws_ok lives_and);
13              
14             my $Tester = Test::Builder->new;
15              
16 1     1   9 sub import {
17 1 50       4 my $self = shift;
18 0         0 if ( @_ ) {
19 0         0 my $package = caller;
20 0         0 $Tester->exported_to( $package );
21             $Tester->plan( @_ );
22 1         377 };
23             $self->export_to_level( 1, $self, $_ ) foreach @EXPORT;
24             }
25              
26             #line 84
27              
28             sub _quiet_caller (;$) { ## no critic Prototypes
29             my $height = $_[0];
30             $height++;
31             if( wantarray and !@_ ) {
32             return (CORE::caller($height))[0..2];
33             }
34             else {
35             return CORE::caller($height);
36             }
37             }
38              
39             sub _try_as_caller {
40             my $coderef = shift;
41              
42             # local works here because Sub::Uplevel has already overridden caller
43             local *CORE::GLOBAL::caller;
44             { no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; }
45              
46             eval { uplevel 3, $coderef };
47             return $@;
48             };
49              
50              
51             sub _is_exception {
52             my $exception = shift;
53             return ref $exception || $exception ne '';
54             };
55              
56              
57             sub _exception_as_string {
58             my ( $prefix, $exception ) = @_;
59             return "$prefix normal exit" unless _is_exception( $exception );
60             my $class = ref $exception;
61             $exception = "$class ($exception)"
62             if $class && "$exception" !~ m/^\Q$class/;
63             chomp $exception;
64             return "$prefix $exception";
65             };
66              
67              
68             #line 169
69              
70              
71             sub throws_ok (&$;$) {
72             my ( $coderef, $expecting, $description ) = @_;
73             croak "throws_ok: must pass exception class/object or regex"
74             unless defined $expecting;
75             $description = _exception_as_string( "threw", $expecting )
76             unless defined $description;
77             my $exception = _try_as_caller( $coderef );
78             my $regex = $Tester->maybe_regex( $expecting );
79             my $ok = $regex
80             ? ( $exception =~ m/$regex/ )
81             : eval {
82             $exception->isa( ref $expecting ? ref $expecting : $expecting )
83             };
84             $Tester->ok( $ok, $description );
85             unless ( $ok ) {
86 60     60   3353 $Tester->diag( _exception_as_string( "expecting:", $expecting ) );
87 60         61 $Tester->diag( _exception_as_string( "found:", $exception ) );
88 60 50 33     237 };
89 0         0 $@ = $exception;
90             return $ok;
91             };
92 60         450  
93              
94             #line 215
95              
96             sub dies_ok (&;$) {
97 4     4   6 my ( $coderef, $description ) = @_;
98             my $exception = _try_as_caller( $coderef );
99             my $ok = $Tester->ok( _is_exception($exception), $description );
100 4         14 $@ = $exception;
101 1     1   9 return $ok;
  1         2  
  1         706  
  4         5  
  4         12  
102             }
103 4         6  
  4         16  
104 4         124  
105             #line 254
106              
107             sub lives_ok (&;$) {
108             my ( $coderef, $description ) = @_;
109 4     4   5 my $exception = _try_as_caller( $coderef );
110 4   33     20 my $ok = $Tester->ok( ! _is_exception( $exception ), $description );
111             $Tester->diag( _exception_as_string( "died:", $exception ) ) unless $ok;
112             $@ = $exception;
113             return $ok;
114             }
115 4     4   7  
116 4 50       11  
117 4         9 #line 294
118 4 50 33     63  
119             sub lives_and (&;$) {
120 4         9 my ( $test, $description ) = @_;
121 4         16 {
122             local $Test::Builder::Level = $Test::Builder::Level + 1;
123             my $ok = \&Test::Builder::ok;
124             no warnings;
125             local *Test::Builder::ok = sub {
126             $_[2] = $description unless defined $_[2];
127             $ok->(@_);
128             };
129             use warnings;
130             eval { $test->() } and return 1;
131             };
132             my $exception = $@;
133             if ( _is_exception( $exception ) ) {
134             $Tester->ok( 0, $description );
135             $Tester->diag( _exception_as_string( "died:", $exception ) );
136             };
137             $@ = $exception;
138             return;
139             }
140              
141             #line 460
142              
143             1;