File Coverage

blib/lib/Test/Exception.pm
Criterion Covered Total %
statement 96 99 96.9
branch 29 32 90.6
condition 7 9 77.7
subroutine 18 18 100.0
pod 4 4 100.0
total 154 162 95.0


line stmt bran cond sub pod time code
1 10     10   320801 use strict;
  10         25  
  10         275  
2 10     10   54 use warnings;
  10         22  
  10         394  
3              
4             package Test::Exception;
5 10     10   400363 use Test::Builder;
  10         14257  
  10         241  
6 10     10   7122 use Sub::Uplevel qw( uplevel );
  10         10918  
  10         69  
7 10     10   441 use base qw( Exporter );
  10         21  
  10         4079  
8              
9             our $VERSION = '0.42_1';
10             $VERSION = eval $VERSION;
11              
12             our @EXPORT = qw(dies_ok lives_ok throws_ok lives_and);
13              
14             my $Tester = Test::Builder->new;
15              
16             sub import {
17 10     10   69 my $self = shift;
18 10 100       53 if ( @_ ) {
19 1         3 my $package = caller;
20 1         18 $Tester->exported_to( $package );
21 1         9 $Tester->plan( @_ );
22             };
23 10         4112 $self->export_to_level( 1, $self, $_ ) foreach @EXPORT;
24             }
25              
26             =head1 NAME
27              
28             Test::Exception - Test exception-based code
29              
30             =head1 SYNOPSIS
31              
32             use Test::More tests => 5;
33             use Test::Exception;
34              
35             # or if you don't need Test::More
36              
37             use Test::Exception tests => 5;
38              
39             # then...
40              
41             # Check that the stringified exception matches given regex
42             throws_ok { $foo->method } qr/division by zero/, 'zero caught okay';
43              
44             # Check an exception of the given class (or subclass) is thrown
45             throws_ok { $foo->method } 'Error::Simple', 'simple error thrown';
46            
47             # all Test::Exceptions subroutines are guaranteed to preserve the state
48             # of $@ so you can do things like this after throws_ok and dies_ok
49             like $@, 'what the stringified exception should look like';
50              
51             # Check that something died - we do not care why
52             dies_ok { $foo->method } 'expecting to die';
53              
54             # Check that something did not die
55             lives_ok { $foo->method } 'expecting to live';
56              
57             # Check that a test runs without an exception
58             lives_and { is $foo->method, 42 } 'method is 42';
59            
60             # or if you don't like prototyped functions
61            
62             throws_ok( sub { $foo->method }, qr/division by zero/,
63             'zero caught okay' );
64             throws_ok( sub { $foo->method }, 'Error::Simple',
65             'simple error thrown' );
66             dies_ok( sub { $foo->method }, 'expecting to die' );
67             lives_ok( sub { $foo->method }, 'expecting to live' );
68             lives_and( sub { is $foo->method, 42 }, 'method is 42' );
69              
70              
71             =head1 DESCRIPTION
72              
73             This module provides a few convenience methods for testing exception based code. It is built with
74             L and plays happily with L and friends.
75              
76             If you are not already familiar with L now would be the time to go take a look.
77              
78             You can specify the test plan when you C in the same way as C.
79             See L for details.
80              
81             NOTE: Test::Exception only checks for exceptions. It will ignore other methods of stopping
82             program execution - including exit(). If you have an exit() in evalled code Test::Exception
83             will not catch this with any of its testing functions.
84              
85             NOTE: This module uses L and relies on overriding
86             C to hide your test blocks from the call stack. If this
87             use of global overrides concerns you, the L module offers a more
88             minimalist alternative.
89              
90             =cut
91              
92             sub _quiet_caller (;$) { ## no critic Prototypes
93 72     72   4032 my $height = $_[0];
94 72         96 $height++;
95              
96 72 100       171 if ( CORE::caller() eq 'DB' ) {
97             # passthrough the @DB::args trick
98             package DB;
99 21 50       54 if( wantarray ) {
100 21 50       47 if ( !@_ ) {
101 0         0 return (CORE::caller($height))[0..2];
102             }
103             else {
104             # If we got here, we are within a Test::Exception test, and
105             # something is producing a stacktrace. In case this is a full
106             # trace (i.e. confess() ), we have to make sure that the sub
107             # args are not visible. If we do not do this, and the test in
108             # question is throws_ok() with a regex, it will end up matching
109             # against itself in the args to throws_ok().
110             #
111             # While it is possible (and maybe wise), to test if we are
112             # indeed running under throws_ok (by crawling the stack right
113             # up from here), the old behavior of Test::Exception was to
114             # simply obliterate @DB::args altogether in _quiet_caller, so
115             # we are just preserving the behavior to avoid surprises
116             #
117 21         132 my @frame_info = CORE::caller($height);
118 21         43 @DB::args = ();
119 21         133 return @frame_info;
120             }
121             }
122              
123             # fallback if nothing above returns
124 0         0 return CORE::caller($height);
125             }
126             else {
127 51 50 33     238 if( wantarray and !@_ ) {
128 0         0 return (CORE::caller($height))[0..2];
129             }
130             else {
131 51         344 return CORE::caller($height);
132             }
133             }
134             }
135              
136             sub _try_as_caller {
137 33     33   62 my $coderef = shift;
138              
139             # local works here because Sub::Uplevel has already overridden caller
140 33         100 local *CORE::GLOBAL::caller;
141 10     10   63 { no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; }
  10         18  
  10         6106  
  33         53  
  33         92  
142              
143 33         65 eval { uplevel 3, $coderef };
  33         105  
144 33         995 return $@;
145             };
146              
147              
148             sub _is_exception {
149 48     48   76 my $exception = shift;
150 48   100     330 return ref $exception || $exception ne '';
151             };
152              
153              
154             sub _exception_as_string {
155 34     34   84 my ( $prefix, $exception ) = @_;
156 34 100       77 return "$prefix normal exit" unless _is_exception( $exception );
157 32         66 my $class = ref $exception;
158 32 100 100     227 $exception = "$class ($exception)"
159             if $class && "$exception" !~ m/^\Q$class/;
160 32         163 chomp $exception;
161 32         164 return "$prefix $exception";
162             };
163              
164              
165             =over 4
166              
167             =item B
168              
169             Tests to see that a specific exception is thrown. throws_ok() has two forms:
170              
171             throws_ok BLOCK REGEX, TEST_DESCRIPTION
172             throws_ok BLOCK CLASS, TEST_DESCRIPTION
173              
174             In the first form the test passes if the stringified exception matches the give regular expression. For example:
175              
176             throws_ok { read_file( 'unreadable' ) } qr/No file/, 'no file';
177              
178             If your perl does not support C you can also pass a regex-like string, for example:
179              
180             throws_ok { read_file( 'unreadable' ) } '/No file/', 'no file';
181              
182             The second form of throws_ok() test passes if the exception is of the same class as the one supplied, or a subclass of that class. For example:
183              
184             throws_ok { $foo->bar } "Error::Simple", 'simple error';
185              
186             Will only pass if the C method throws an Error::Simple exception, or a subclass of an Error::Simple exception.
187              
188             You can get the same effect by passing an instance of the exception you want to look for. The following is equivalent to the previous example:
189              
190             my $SIMPLE = Error::Simple->new;
191             throws_ok { $foo->bar } $SIMPLE, 'simple error';
192              
193             Should a throws_ok() test fail it produces appropriate diagnostic messages. For example:
194              
195             not ok 3 - simple error
196             # Failed test (test.t at line 48)
197             # expecting: Error::Simple exception
198             # found: normal exit
199              
200             Like all other Test::Exception functions you can avoid prototypes by passing a subroutine explicitly:
201              
202             throws_ok( sub {$foo->bar}, "Error::Simple", 'simple error' );
203              
204             A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
205              
206             A description of the exception being checked is used if no optional test description is passed.
207              
208             NOTE: Remember when you C perl will
209             automatically add the current script line number, input line number and a newline. This will
210             form part of the string that throws_ok regular expressions match against.
211              
212              
213             =cut
214              
215              
216             sub throws_ok (&$;$) {
217 22     22 1 12898 my ( $coderef, $expecting, $description ) = @_;
218 22 100       84 unless (defined $expecting) {
219 1         8 require Carp;
220 1         21 Carp::croak( "throws_ok: must pass exception class/object or regex" );
221             }
222 21 100       80 $description = _exception_as_string( "threw", $expecting )
223             unless defined $description;
224 21         56 my $exception = _try_as_caller( $coderef );
225 21         91 my $regex = $Tester->maybe_regex( $expecting );
226             my $ok = $regex
227             ? ( $exception =~ m/$regex/ )
228 21 100       476 : eval {
229 9 100       69 $exception->isa( ref $expecting ? ref $expecting : $expecting )
230             };
231 21         88 $Tester->ok( $ok, $description );
232 21 100       9020 unless ( $ok ) {
233 9         25 $Tester->diag( _exception_as_string( "expecting:", $expecting ) );
234 9         704 $Tester->diag( _exception_as_string( "found:", $exception ) );
235             };
236 21         765 $@ = $exception;
237 21         187 return $ok;
238             };
239              
240              
241             =item B
242              
243             Checks that a piece of code dies, rather than returning normally. For example:
244              
245             sub div {
246             my ( $a, $b ) = @_;
247             return $a / $b;
248             };
249              
250             dies_ok { div( 1, 0 ) } 'divide by zero detected';
251              
252             # or if you don't like prototypes
253             dies_ok( sub { div( 1, 0 ) }, 'divide by zero detected' );
254              
255             A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
256              
257             Remember: This test will pass if the code dies for any reason. If you care about the reason it might be more sensible to write a more specific test using throws_ok().
258              
259             The test description is optional, but recommended.
260              
261             =cut
262              
263             sub dies_ok (&;$) {
264 6     6 1 2506 my ( $coderef, $description ) = @_;
265 6         23 my $exception = _try_as_caller( $coderef );
266 6         52 my $ok = $Tester->ok( _is_exception($exception), $description );
267 6         2779 $@ = $exception;
268 6         20 return $ok;
269             }
270              
271              
272             =item B
273              
274             Checks that a piece of code doesn't die. This allows your test script to continue, rather than aborting if you get an unexpected exception. For example:
275              
276             sub read_file {
277             my $file = shift;
278             local $/;
279             open my $fh, '<', $file or die "open failed ($!)\n";
280             $file = ;
281             return $file;
282             };
283              
284             my $file;
285             lives_ok { $file = read_file('test.txt') } 'file read';
286              
287             # or if you don't like prototypes
288             lives_ok( sub { $file = read_file('test.txt') }, 'file read' );
289              
290             Should a lives_ok() test fail it produces appropriate diagnostic messages. For example:
291              
292             not ok 1 - file read
293             # Failed test (test.t at line 15)
294             # died: open failed (No such file or directory)
295              
296             A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
297              
298             The test description is optional, but recommended.
299              
300             =cut
301              
302             sub lives_ok (&;$) {
303 6     6 1 4482 my ( $coderef, $description ) = @_;
304 6         16 my $exception = _try_as_caller( $coderef );
305 6         17 my $ok = $Tester->ok( ! _is_exception( $exception ), $description );
306 6 100       2610 $Tester->diag( _exception_as_string( "died:", $exception ) ) unless $ok;
307 6         311 $@ = $exception;
308 6         20 return $ok;
309             }
310              
311              
312             =item B
313              
314             Run a test that may throw an exception. For example, instead of doing:
315              
316             my $file;
317             lives_ok { $file = read_file('answer.txt') } 'read_file worked';
318             is $file, "42", 'answer was 42';
319              
320             You can use lives_and() like this:
321              
322             lives_and { is read_file('answer.txt'), "42" } 'answer is 42';
323             # or if you don't like prototypes
324             lives_and(sub {is read_file('answer.txt'), "42"}, 'answer is 42');
325              
326             Which is the same as doing
327              
328             is read_file('answer.txt'), "42\n", 'answer is 42';
329              
330             unless C dies, in which case you get the same kind of error as lives_ok()
331              
332             not ok 1 - answer is 42
333             # Failed test (test.t at line 15)
334             # died: open failed (No such file or directory)
335              
336             A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
337              
338             The test description is optional, but recommended.
339              
340             =cut
341              
342             sub lives_and (&;$) {
343 4     4 1 1052 my ( $test, $description ) = @_;
344             {
345 4         8 my $ok = \&Test::Builder::ok;
  4         7  
346 10     10   55 no warnings;
  10         17  
  10         983  
347             local *Test::Builder::ok = sub {
348 3     3   266 local $Test::Builder::Level = $Test::Builder::Level + 1;
349 3 100       11 $_[2] = $description unless defined $_[2];
350 3         11 $ok->(@_);
351 4         20 };
352 10     10   53 use warnings;
  10         16  
  10         1551  
353 4 100       8 eval { $test->() } and return 1;
  4         11  
354             };
355 2         758 my $exception = $@;
356 2 100       6 if ( _is_exception( $exception ) ) {
357 1         5 $Tester->ok( 0, $description );
358 1         530 $Tester->diag( _exception_as_string( "died:", $exception ) );
359             };
360 2         81 $@ = $exception;
361 2         7 return;
362             }
363              
364             =back
365              
366              
367             =head1 SKIPPING TEST::EXCEPTION TESTS
368              
369             Sometimes we want to use Test::Exception tests in a test suite, but don't want to force the user to have Test::Exception installed. One way to do this is to skip the tests if Test::Exception is absent. You can do this with code something like this:
370              
371             use strict;
372             use warnings;
373             use Test::More;
374            
375             BEGIN {
376             eval "use Test::Exception";
377             plan skip_all => "Test::Exception needed" if $@;
378             }
379            
380             plan tests => 2;
381             # ... tests that need Test::Exception ...
382              
383             Note that we load Test::Exception in a C block ensuring that the subroutine prototypes are in place before the rest of the test script is compiled.
384              
385              
386             =head1 BUGS
387              
388             There are some edge cases in Perl's exception handling where Test::Exception will miss exceptions
389             thrown in DESTROY blocks. See the RT bug L for
390             details, along with the t/edge-cases.t in the distribution test suite. These will be addressed in
391             a future Test::Exception release.
392              
393             If you find any more bugs please let me know by e-mail, or report the problem with
394             L.
395              
396              
397             =head1 COMMUNITY
398              
399             =over 4
400              
401             =item perl-qa
402              
403             If you are interested in testing using Perl I recommend you visit L and join the excellent perl-qa mailing list. See L for details on how to subscribe.
404              
405             =item perlmonks
406              
407             You can find users of Test::Exception, including the module author, on L. Feel free to ask questions on Test::Exception there.
408              
409             =item CPAN::Forum
410              
411             The CPAN Forum is a web forum for discussing Perl's CPAN modules. The Test::Exception forum can be found at L.
412              
413             =item AnnoCPAN
414              
415             AnnoCPAN is a web site that allows community annotations of Perl module documentation. The Test::Exception annotations can be found at L.
416              
417             =back
418              
419              
420             =head1 TO DO
421              
422             If you think this module should do something that it doesn't (or does something that it shouldn't) please let me know.
423              
424             You can see my current to do list at L, with an RSS feed of changes at L.
425              
426              
427             =head1 ACKNOWLEDGMENTS
428              
429             Thanks to chromatic and Michael G Schwern for the excellent Test::Builder, without which this module wouldn't be possible.
430              
431             Thanks to
432             Adam Kennedy,
433             Andy Lester,
434             Aristotle Pagaltzis,
435             Ben Prew,
436             Cees Hek,
437             Chris Dolan,
438             chromatic,
439             Curt Sampson,
440             David Cantrell,
441             David Golden,
442             David Tulloh,
443             David Wheeler,
444             J. K. O'Brien,
445             Janek Schleicher,
446             Jim Keenan,
447             Jos I. Boumans,
448             Joshua ben Jore,
449             Jost Krieger,
450             Mark Fowler,
451             Michael G Schwern,
452             Nadim Khemir,
453             Paul McCann,
454             Perrin Harkins,
455             Peter Rabbitson,
456             Peter Scott,
457             Ricardo Signes,
458             Rob Muhlestein,
459             Scott R. Godin,
460             Steve Purkis,
461             Steve,
462             Tim Bunce,
463             and various anonymous folk for comments, suggestions, bug reports and patches.
464              
465             =head1 AUTHOR
466              
467             Adrian Howard
468              
469             If you can spare the time, please drop me a line if you find this module useful.
470              
471              
472             =head1 SEE ALSO
473              
474             =over 4
475              
476             =item L
477              
478             Delicious links on Test::Exception.
479              
480             =item L
481              
482             A slightly different interface to testing exceptions, without overriding C.
483              
484             =item L & L & L
485              
486             Modules to help test warnings.
487              
488             =item L
489              
490             Support module for building test libraries.
491              
492             =item L & L
493              
494             Basic utilities for writing tests.
495              
496             =item L
497              
498             Overview of some of the many testing modules available on CPAN.
499              
500             =item L
501              
502             Delicious links on perl testing.
503              
504             =back
505              
506              
507             =head1 LICENCE
508              
509             Copyright 2002-2007 Adrian Howard, All Rights Reserved.
510              
511             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
512              
513             =cut
514              
515             1;