File Coverage

inc/Test/Exception.pm
Criterion Covered Total %
statement 27 91 29.6
branch 1 26 3.8
condition 0 9 0.0
subroutine 9 18 50.0
pod 4 4 100.0
total 41 148 27.7


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