File Coverage

inc/Test/Exception.pm
Criterion Covered Total %
statement 48 92 52.1
branch 2 26 7.6
condition 2 9 22.2
subroutine 14 19 73.6
pod 4 4 100.0
total 70 150 46.6


line stmt bran cond sub pod time code
1 1     1   734 #line 1
  1         3  
  1         43  
2 1     1   6 use strict;
  1         2  
  1         41  
3             use warnings;
4              
5 1     1   5 package Test::Exception;
  1         3  
  1         29  
6 1     1   738 use Test::Builder;
  1         3  
  1         73  
7 1     1   6 use Sub::Uplevel qw( uplevel );
  1         3  
  1         113  
8 1     1   5 use base qw( Exporter );
  1         3  
  1         419  
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   7 sub import {
17 1 50       8 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         302 };
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 8     8   11 $Tester->diag( _exception_as_string( "expecting:", $expecting ) );
87 8         9 $Tester->diag( _exception_as_string( "found:", $exception ) );
88 8 50 33     36 };
89 0         0 $@ = $exception;
90             return $ok;
91             };
92 8         60  
93              
94             #line 215
95              
96             sub dies_ok (&;$) {
97 1     1   2 my ( $coderef, $description ) = @_;
98             my $exception = _try_as_caller( $coderef );
99             my $ok = $Tester->ok( _is_exception($exception), $description );
100 1         5 $@ = $exception;
101 1     1   7 return $ok;
  1         2  
  1         719  
  1         3  
  1         4  
102             }
103 1         3  
  1         6  
104 1         30  
105             #line 254
106              
107             sub lives_ok (&;$) {
108             my ( $coderef, $description ) = @_;
109 1     1   3 my $exception = _try_as_caller( $coderef );
110 1   33     16 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 0     0   0  
116 0 0       0  
117 0         0 #line 294
118 0 0 0     0  
119             sub lives_and (&;$) {
120 0         0 my ( $test, $description ) = @_;
121 0         0 {
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;