File Coverage

blib/lib/Test/Fatal.pm
Criterion Covered Total %
statement 56 57 98.2
branch 15 20 75.0
condition 7 12 58.3
subroutine 12 12 100.0
pod 4 4 100.0
total 94 105 89.5


line stmt bran cond sub pod time code
1 3     3   173996 use strict;
  3         21  
  3         81  
2 3     3   12 use warnings;
  3         5  
  3         148  
3             package Test::Fatal;
4             # ABSTRACT: incredibly simple helpers for testing code with exceptions
5             $Test::Fatal::VERSION = '0.017';
6             #pod =head1 SYNOPSIS
7             #pod
8             #pod use Test::More;
9             #pod use Test::Fatal;
10             #pod
11             #pod use System::Under::Test qw(might_die);
12             #pod
13             #pod is(
14             #pod exception { might_die; },
15             #pod undef,
16             #pod "the code lived",
17             #pod );
18             #pod
19             #pod like(
20             #pod exception { might_die; },
21             #pod qr/turns out it died/,
22             #pod "the code died as expected",
23             #pod );
24             #pod
25             #pod isa_ok(
26             #pod exception { might_die; },
27             #pod 'Exception::Whatever',
28             #pod 'the thrown exception',
29             #pod );
30             #pod
31             #pod =head1 DESCRIPTION
32             #pod
33             #pod Test::Fatal is an alternative to the popular L. It does much
34             #pod less, but should allow greater flexibility in testing exception-throwing code
35             #pod with about the same amount of typing.
36             #pod
37             #pod It exports one routine by default: C.
38             #pod
39             #pod B C intentionally does not manipulate the call stack.
40             #pod User-written test functions that use C must be careful to avoid
41             #pod false positives if exceptions use stack traces that show arguments. For a more
42             #pod magical approach involving globally overriding C, see
43             #pod L.
44             #pod
45             #pod =cut
46              
47 3     3   15 use Carp ();
  3         4  
  3         79  
48 3     3   1471 use Try::Tiny 0.07;
  3         5618  
  3         184  
49              
50 3     3   18 use Exporter 5.57 'import';
  3         30  
  3         4592  
51              
52             our @EXPORT = qw(exception);
53             our @EXPORT_OK = qw(exception success dies_ok lives_ok);
54              
55             #pod =func exception
56             #pod
57             #pod my $exception = exception { ... };
58             #pod
59             #pod C takes a bare block of code and returns the exception thrown by
60             #pod that block. If no exception was thrown, it returns undef.
61             #pod
62             #pod B If the block results in a I exception, such as 0 or the
63             #pod empty string, Test::Fatal itself will die. Since either of these cases
64             #pod indicates a serious problem with the system under testing, this behavior is
65             #pod considered a I. If you must test for these conditions, you should use
66             #pod L's try/catch mechanism. (Try::Tiny is the underlying exception
67             #pod handling system of Test::Fatal.)
68             #pod
69             #pod Note that there is no TAP assert being performed. In other words, no "ok" or
70             #pod "not ok" line is emitted. It's up to you to use the rest of C in an
71             #pod existing test like C, C, C, et cetera. Or you may wish to use
72             #pod the C and C wrappers, which do provide TAP output.
73             #pod
74             #pod C does I alter the stack presented to the called block, meaning
75             #pod that if the exception returned has a stack trace, it will include some frames
76             #pod between the code calling C and the thing throwing the exception.
77             #pod This is considered a I because it avoids the occasionally twitchy
78             #pod C mechanism.
79             #pod
80             #pod B This is not a great idea:
81             #pod
82             #pod sub exception_like(&$;$) {
83             #pod my ($code, $pattern, $name) = @_;
84             #pod like( &exception($code), $pattern, $name );
85             #pod }
86             #pod
87             #pod exception_like(sub { }, qr/foo/, 'foo appears in the exception');
88             #pod
89             #pod If the code in the C<...> is going to throw a stack trace with the arguments to
90             #pod each subroutine in its call stack (for example via C,
91             #pod the test name, "foo appears in the exception" will itself be matched by the
92             #pod regex. Instead, write this:
93             #pod
94             #pod like( exception { ... }, qr/foo/, 'foo appears in the exception' );
95             #pod
96             #pod If you really want a test function that passes the test name, wrap the
97             #pod arguments in an array reference to hide the literal text from a stack trace:
98             #pod
99             #pod sub exception_like(&$) {
100             #pod my ($code, $args) = @_;
101             #pod my ($pattern, $name) = @$args;
102             #pod like( &exception($code), $pattern, $name );
103             #pod }
104             #pod
105             #pod exception_like(sub { }, [ qr/foo/, 'foo appears in the exception' ] );
106             #pod
107             #pod To aid in avoiding the problem where the pattern is seen in the exception
108             #pod because of the call stack, C<$Carp::MaxArgNums> is locally set to -1 when the
109             #pod code block is called. If you really don't want that, set it back to whatever
110             #pod value you like at the beginning of the code block. Obviously, this solution
111             #pod doens't affect all possible ways that args of subroutines in the call stack
112             #pod might taint the test. The intention here is to prevent some false passes from
113             #pod people who didn't read the documentation. Your punishment for reading it is
114             #pod that you must consider whether to do anything about this.
115             #pod
116             #pod B: One final bad idea:
117             #pod
118             #pod isnt( exception { ... }, undef, "my code died!");
119             #pod
120             #pod It's true that this tests that your code died, but you should really test that
121             #pod it died I. For example, if you make an unrelated mistake
122             #pod in the block, like using the wrong dereference, your test will pass even though
123             #pod the code to be tested isn't really run at all. If you're expecting an
124             #pod inspectable exception with an identifier or class, test that. If you're
125             #pod expecting a string exception, consider using C.
126             #pod
127             #pod =cut
128              
129             our ($REAL_TBL, $REAL_CALCULATED_TBL) = (1, 1);
130              
131             sub exception (&) {
132 15     15 1 8714 my $code = shift;
133              
134             return try {
135 15 50   15   651 my $incremented = defined $Test::Builder::Level
136             ? $Test::Builder::Level - $REAL_CALCULATED_TBL
137             : 0;
138 15         24 local $Test::Builder::Level = $REAL_CALCULATED_TBL;
139 15 100       81 if ($incremented) {
140             # each call to exception adds 5 stack frames
141 4         13 $Test::Builder::Level += 5;
142 4         10 for my $i (1..$incremented) {
143             # -2 because we want to see it from the perspective of the call to
144             # is() within the call to $code->()
145 5         7 my $caller = caller($Test::Builder::Level - 2);
146 5 50       8 if ($caller eq __PACKAGE__) {
147             # each call to exception adds 5 stack frames
148 0         0 $Test::Builder::Level = $Test::Builder::Level + 5;
149             }
150             else {
151 5         9 $Test::Builder::Level = $Test::Builder::Level + 1;
152             }
153             }
154             }
155              
156 15         24 local $REAL_CALCULATED_TBL = $Test::Builder::Level;
157 15         20 local $Carp::MaxArgNums = -1;
158 15         35 $code->();
159 9         5780 return undef;
160             } catch {
161 6 100   6   331 return $_ if $_;
162              
163 1 50       14 my $problem = defined $_ ? 'false' : 'undef';
164 1         259 Carp::confess("$problem exception caught by Test::Fatal::exception");
165 15         88 };
166             }
167              
168             #pod =func success
169             #pod
170             #pod try {
171             #pod should_live;
172             #pod } catch {
173             #pod fail("boo, we died");
174             #pod } success {
175             #pod pass("hooray, we lived");
176             #pod };
177             #pod
178             #pod C, exported only by request, is a L helper with semantics
179             #pod identical to L|Try::Tiny/finally>, but the body of the block will
180             #pod only be run if the C block ran without error.
181             #pod
182             #pod Although almost any needed exception tests can be performed with C,
183             #pod success blocks may sometimes help organize complex testing.
184             #pod
185             #pod =cut
186              
187             sub success (&;@) {
188 3     3 1 502 my $code = shift;
189             return finally( sub {
190 3 100   3   668 return if @_; # <-- only run on success
191 1         2 $code->();
192 3         10 }, @_ );
193             }
194              
195             #pod =func dies_ok
196             #pod
197             #pod =func lives_ok
198             #pod
199             #pod Exported only by request, these two functions run a given block of code, and
200             #pod provide TAP output indicating if it did, or did not throw an exception.
201             #pod These provide an easy upgrade path for replacing existing unit tests based on
202             #pod C.
203             #pod
204             #pod RJBS does not suggest using this except as a convenience while porting tests to
205             #pod use Test::Fatal's C routine.
206             #pod
207             #pod use Test::More tests => 2;
208             #pod use Test::Fatal qw(dies_ok lives_ok);
209             #pod
210             #pod dies_ok { die "I failed" } 'code that fails';
211             #pod
212             #pod lives_ok { return "I'm still alive" } 'code that does not fail';
213             #pod
214             #pod =cut
215              
216             my $Tester;
217              
218             # Signature should match that of Test::Exception
219             sub dies_ok (&;$) {
220 3     3 1 9558 my $code = shift;
221 3         31 my $name = shift;
222              
223 3         16 require Test::Builder;
224 3   66     15 $Tester ||= Test::Builder->new;
225              
226 3         17 my $tap_pos = $Tester->current_test;
227              
228 3         611 my $exception = exception( \&$code );
229              
230 3 50 66     127 $name ||= $tap_pos != $Tester->current_test
231             ? "...and code should throw an exception"
232             : "code should throw an exception";
233              
234 3         120 my $ok = $Tester->ok( $exception, $name );
235 3 100       1595 $ok or $Tester->diag( "expected an exception but none was raised" );
236 3         206 return $ok;
237             }
238              
239             sub lives_ok (&;$) {
240 3     3 1 6167 my $code = shift;
241 3         4 my $name = shift;
242              
243 3         14 require Test::Builder;
244 3   33     8 $Tester ||= Test::Builder->new;
245              
246 3         7 my $tap_pos = $Tester->current_test;
247              
248 3         263 my $exception = exception( \&$code );
249              
250 3 50 66     44 $name ||= $tap_pos != $Tester->current_test
251             ? "...and code should not throw an exception"
252             : "code should not throw an exception";
253              
254 3         97 my $ok = $Tester->ok( ! $exception, $name );
255 3 100       1230 $ok or $Tester->diag( "expected return but an exception was raised" );
256 3         202 return $ok;
257             }
258              
259             1;
260              
261             __END__