1 | use strict;
|
---|
2 | use warnings;
|
---|
3 |
|
---|
4 | package Test::Exception;
|
---|
5 | use Test::Builder;
|
---|
6 | use Sub::Uplevel qw( uplevel );
|
---|
7 | use base qw( Exporter );
|
---|
8 | use Carp;
|
---|
9 |
|
---|
10 | our $VERSION = '0.24';
|
---|
11 | our @EXPORT = qw(dies_ok lives_ok throws_ok lives_and);
|
---|
12 |
|
---|
13 | my $Tester = Test::Builder->new;
|
---|
14 |
|
---|
15 | sub import {
|
---|
16 | my $self = shift;
|
---|
17 | if ( @_ ) {
|
---|
18 | my $package = caller;
|
---|
19 | $Tester->exported_to( $package );
|
---|
20 | $Tester->plan( @_ );
|
---|
21 | };
|
---|
22 | $self->export_to_level( 1, $self, $_ ) foreach @EXPORT;
|
---|
23 | }
|
---|
24 |
|
---|
25 | =head1 NAME
|
---|
26 |
|
---|
27 | Test::Exception - Test exception based code
|
---|
28 |
|
---|
29 | =head1 SYNOPSIS
|
---|
30 |
|
---|
31 | use Test::More tests => 5;
|
---|
32 | use Test::Exception;
|
---|
33 |
|
---|
34 | # or if you don't need Test::More
|
---|
35 |
|
---|
36 | use Test::Exception tests => 5;
|
---|
37 |
|
---|
38 | # then...
|
---|
39 |
|
---|
40 | # Check that something died
|
---|
41 | dies_ok { $foo->method1 } 'expecting to die';
|
---|
42 |
|
---|
43 | # Check that something did not die
|
---|
44 | lives_ok { $foo->method2 } 'expecting to live';
|
---|
45 |
|
---|
46 | # Check that the stringified exception matches given regex
|
---|
47 | throws_ok { $foo->method3 } qr/division by zero/, 'zero caught okay';
|
---|
48 |
|
---|
49 | # Check an exception of the given class (or subclass) is thrown
|
---|
50 | throws_ok { $foo->method4 } 'Error::Simple', 'simple error thrown';
|
---|
51 |
|
---|
52 | # all Test::Exceptions subroutines are guaranteed to preserve the state
|
---|
53 | # of $@ so you can do things like this after throws_ok and dies_ok
|
---|
54 | like $@, 'what the stringified exception should look like';
|
---|
55 |
|
---|
56 | # Check that a test runs without an exception
|
---|
57 | lives_and { is $foo->method, 42 } 'method is 42';
|
---|
58 |
|
---|
59 | # or if you don't like prototyped functions
|
---|
60 |
|
---|
61 | dies_ok( sub { $foo->method1 }, 'expecting to die' );
|
---|
62 | lives_ok( sub { $foo->method2 }, 'expecting to live' );
|
---|
63 | throws_ok( sub { $foo->method3 }, qr/division by zero/,
|
---|
64 | 'zero caught okay' );
|
---|
65 | throws_ok( sub { $foo->method4 }, 'Error::Simple',
|
---|
66 | 'simple error thrown' );
|
---|
67 | lives_and( sub { is $foo->method, 42 }, 'method is 42' );
|
---|
68 |
|
---|
69 |
|
---|
70 | =head1 DESCRIPTION
|
---|
71 |
|
---|
72 | This module provides a few convenience methods for testing exception based code. It is built with L<Test::Builder> and plays happily with L<Test::More> and friends.
|
---|
73 |
|
---|
74 | If you are not already familiar with L<Test::More> now would be the time to go take a look.
|
---|
75 |
|
---|
76 | You can specify the test plan when you C<use Test::Exception> in the same way as C<use Test::More>. See L<Test::More> for details.
|
---|
77 |
|
---|
78 | =cut
|
---|
79 |
|
---|
80 |
|
---|
81 | sub _try_as_caller {
|
---|
82 | my $coderef = shift;
|
---|
83 | eval { uplevel 3, $coderef };
|
---|
84 | return $@;
|
---|
85 | };
|
---|
86 |
|
---|
87 |
|
---|
88 | sub _is_exception {
|
---|
89 | my $exception = shift;
|
---|
90 | return ref $exception || $exception ne '';
|
---|
91 | };
|
---|
92 |
|
---|
93 |
|
---|
94 | sub _exception_as_string {
|
---|
95 | my ( $prefix, $exception ) = @_;
|
---|
96 | return "$prefix normal exit" unless _is_exception( $exception );
|
---|
97 | my $class = ref $exception;
|
---|
98 | $exception = "$class ($exception)"
|
---|
99 | if $class && "$exception" !~ m/^\Q$class/;
|
---|
100 | chomp $exception;
|
---|
101 | return "$prefix $exception";
|
---|
102 | };
|
---|
103 |
|
---|
104 |
|
---|
105 | =over 4
|
---|
106 |
|
---|
107 | =item B<dies_ok>
|
---|
108 |
|
---|
109 | Checks that a piece of code dies, rather than returning normally. For example:
|
---|
110 |
|
---|
111 | sub div {
|
---|
112 | my ( $a, $b ) = @_;
|
---|
113 | return $a / $b;
|
---|
114 | };
|
---|
115 |
|
---|
116 | dies_ok { div( 1, 0 ) } 'divide by zero detected';
|
---|
117 |
|
---|
118 | # or if you don't like prototypes
|
---|
119 | dies_ok( sub { div( 1, 0 ) }, 'divide by zero detected' );
|
---|
120 |
|
---|
121 | A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
|
---|
122 |
|
---|
123 | The test description is optional, but recommended.
|
---|
124 |
|
---|
125 | =cut
|
---|
126 |
|
---|
127 |
|
---|
128 | sub dies_ok (&;$) {
|
---|
129 | my ( $coderef, $description ) = @_;
|
---|
130 | my $exception = _try_as_caller( $coderef );
|
---|
131 | my $ok = $Tester->ok( _is_exception($exception), $description );
|
---|
132 | $@ = $exception;
|
---|
133 | return $ok;
|
---|
134 | }
|
---|
135 |
|
---|
136 |
|
---|
137 | =item B<lives_ok>
|
---|
138 |
|
---|
139 | Checks that a piece of code exits normally, and doesn't die. For example:
|
---|
140 |
|
---|
141 | sub read_file {
|
---|
142 | my $file = shift;
|
---|
143 | local $/;
|
---|
144 | open my $fh, '<', $file or die "open failed ($!)\n";
|
---|
145 | $file = <FILE>;
|
---|
146 | return $file;
|
---|
147 | };
|
---|
148 |
|
---|
149 | my $file;
|
---|
150 | lives_ok { $file = read_file('test.txt') } 'file read';
|
---|
151 |
|
---|
152 | # or if you don't like prototypes
|
---|
153 | lives_ok( sub { $file = read_file('test.txt') }, 'file read' );
|
---|
154 |
|
---|
155 | Should a lives_ok() test fail it produces appropriate diagnostic messages. For example:
|
---|
156 |
|
---|
157 | not ok 1 - file read
|
---|
158 | # Failed test (test.t at line 15)
|
---|
159 | # died: open failed (No such file or directory)
|
---|
160 |
|
---|
161 | A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
|
---|
162 |
|
---|
163 | The test description is optional, but recommended.
|
---|
164 |
|
---|
165 | =cut
|
---|
166 |
|
---|
167 | sub lives_ok (&;$) {
|
---|
168 | my ( $coderef, $description ) = @_;
|
---|
169 | my $exception = _try_as_caller( $coderef );
|
---|
170 | my $ok = $Tester->ok( ! _is_exception( $exception ), $description );
|
---|
171 | $Tester->diag( _exception_as_string( "died:", $exception ) ) unless $ok;
|
---|
172 | $@ = $exception;
|
---|
173 | return $ok;
|
---|
174 | }
|
---|
175 |
|
---|
176 |
|
---|
177 | =item B<throws_ok>
|
---|
178 |
|
---|
179 | Tests to see that a specific exception is thrown. throws_ok() has two forms:
|
---|
180 |
|
---|
181 | throws_ok BLOCK REGEX, TEST_DESCRIPTION
|
---|
182 | throws_ok BLOCK CLASS, TEST_DESCRIPTION
|
---|
183 |
|
---|
184 | In the first form the test passes if the stringified exception matches the give regular expression. For example:
|
---|
185 |
|
---|
186 | throws_ok { read_file( 'unreadable' ) } qr/No file/, 'no file';
|
---|
187 |
|
---|
188 | If your perl does not support C<qr//> you can also pass a regex-like string, for example:
|
---|
189 |
|
---|
190 | throws_ok { read_file( 'unreadable' ) } '/No file/', 'no file';
|
---|
191 |
|
---|
192 | 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:
|
---|
193 |
|
---|
194 | throws_ok { $foo->bar } "Error::Simple", 'simple error';
|
---|
195 |
|
---|
196 | Will only pass if the C<bar> method throws an Error::Simple exception, or a subclass of an Error::Simple exception.
|
---|
197 |
|
---|
198 | 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:
|
---|
199 |
|
---|
200 | my $SIMPLE = Error::Simple->new;
|
---|
201 | throws_ok { $foo->bar } $SIMPLE, 'simple error';
|
---|
202 |
|
---|
203 | Should a throws_ok() test fail it produces appropriate diagnostic messages. For example:
|
---|
204 |
|
---|
205 | not ok 3 - simple error
|
---|
206 | # Failed test (test.t at line 48)
|
---|
207 | # expecting: Error::Simple exception
|
---|
208 | # found: normal exit
|
---|
209 |
|
---|
210 | Like all other Test::Exception functions you can avoid prototypes by passing a subroutine explicitly:
|
---|
211 |
|
---|
212 | throws_ok( sub {$foo->bar}, "Error::Simple", 'simple error' );
|
---|
213 |
|
---|
214 | A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
|
---|
215 |
|
---|
216 | A description of the exception being checked is used if no optional test description is passed.
|
---|
217 |
|
---|
218 | =cut
|
---|
219 |
|
---|
220 |
|
---|
221 | sub throws_ok (&$;$) {
|
---|
222 | my ( $coderef, $expecting, $description ) = @_;
|
---|
223 | croak "throws_ok: must pass exception class/object or regex"
|
---|
224 | unless defined $expecting;
|
---|
225 | $description = _exception_as_string( "threw", $expecting )
|
---|
226 | unless defined $description;
|
---|
227 | my $exception = _try_as_caller( $coderef );
|
---|
228 | my $regex = $Tester->maybe_regex( $expecting );
|
---|
229 | my $ok = $regex
|
---|
230 | ? ( $exception =~ m/$regex/ )
|
---|
231 | : eval {
|
---|
232 | $exception->isa( ref $expecting ? ref $expecting : $expecting )
|
---|
233 | };
|
---|
234 | $Tester->ok( $ok, $description );
|
---|
235 | unless ( $ok ) {
|
---|
236 | $Tester->diag( _exception_as_string( "expecting:", $expecting ) );
|
---|
237 | $Tester->diag( _exception_as_string( "found:", $exception ) );
|
---|
238 | };
|
---|
239 | $@ = $exception;
|
---|
240 | return $ok;
|
---|
241 | };
|
---|
242 |
|
---|
243 |
|
---|
244 | =item B<lives_and>
|
---|
245 |
|
---|
246 | Run a test that may throw an exception. For example, instead of doing:
|
---|
247 |
|
---|
248 | my $file;
|
---|
249 | lives_ok { $file = read_file('answer.txt') } 'read_file worked';
|
---|
250 | is $file, "42", 'answer was 42';
|
---|
251 |
|
---|
252 | You can use lives_and() like this:
|
---|
253 |
|
---|
254 | lives_and { is read_file('answer.txt'), "42" } 'answer is 42';
|
---|
255 | # or if you don't like prototypes
|
---|
256 | lives_and(sub {is read_file('answer.txt'), "42"}, 'answer is 42');
|
---|
257 |
|
---|
258 | Which is the same as doing
|
---|
259 |
|
---|
260 | is read_file('answer.txt'), "42\n", 'answer is 42';
|
---|
261 |
|
---|
262 | unless C<read_file('answer.txt')> dies, in which case you get the same kind of error as lives_ok()
|
---|
263 |
|
---|
264 | not ok 1 - answer is 42
|
---|
265 | # Failed test (test.t at line 15)
|
---|
266 | # died: open failed (No such file or directory)
|
---|
267 |
|
---|
268 | A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any).
|
---|
269 |
|
---|
270 | The test description is optional, but recommended.
|
---|
271 |
|
---|
272 | =cut
|
---|
273 |
|
---|
274 | sub lives_and (&;$) {
|
---|
275 | my ( $test, $description ) = @_;
|
---|
276 | {
|
---|
277 | local $Test::Builder::Level = $Test::Builder::Level + 1;
|
---|
278 | my $ok = \&Test::Builder::ok;
|
---|
279 | no warnings;
|
---|
280 | local *Test::Builder::ok = sub {
|
---|
281 | $_[2] = $description unless defined $_[2];
|
---|
282 | $ok->(@_);
|
---|
283 | };
|
---|
284 | use warnings;
|
---|
285 | eval { $test->() } and return 1;
|
---|
286 | };
|
---|
287 | my $exception = $@;
|
---|
288 | if ( _is_exception( $exception ) ) {
|
---|
289 | $Tester->ok( 0, $description );
|
---|
290 | $Tester->diag( _exception_as_string( "died:", $exception ) );
|
---|
291 | };
|
---|
292 | $@ = $exception;
|
---|
293 | return;
|
---|
294 | }
|
---|
295 |
|
---|
296 | =back
|
---|
297 |
|
---|
298 |
|
---|
299 | =head1 SKIPPING TEST::EXCEPTION TESTS
|
---|
300 |
|
---|
301 | 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:
|
---|
302 |
|
---|
303 | use strict;
|
---|
304 | use warnings;
|
---|
305 | use Test::More;
|
---|
306 |
|
---|
307 | BEGIN {
|
---|
308 | eval "use Test::Exception";
|
---|
309 | plan skip_all => "Test::Exception needed" if $@;
|
---|
310 | }
|
---|
311 |
|
---|
312 | plan tests => 2;
|
---|
313 | # ... tests that need Test::Exception ...
|
---|
314 |
|
---|
315 | Note that we load Test::Exception in a C<BEGIN> block ensuring that the subroutine prototypes are in place before the rest of the test script is compiled.
|
---|
316 |
|
---|
317 |
|
---|
318 | =head1 BUGS
|
---|
319 |
|
---|
320 | None known at the time of writing.
|
---|
321 |
|
---|
322 | If you find any please let me know by e-mail, or report the problem with L<http://rt.cpan.org/>.
|
---|
323 |
|
---|
324 |
|
---|
325 | =head1 COMMUNITY
|
---|
326 |
|
---|
327 | =over 4
|
---|
328 |
|
---|
329 | =item perl-qa
|
---|
330 |
|
---|
331 | If you are interested in testing using Perl I recommend you visit L<http://qa.perl.org/> and join the excellent perl-qa mailing list. See L<http://lists.perl.org/showlist.cgi?name=perl-qa> for details on how to subscribe.
|
---|
332 |
|
---|
333 | =item perlmonks
|
---|
334 |
|
---|
335 | You can find users of Test::Exception, including the module author, on L<http://www.perlmonks.org/>. Feel free to ask questions on Test::Exception there.
|
---|
336 |
|
---|
337 | =item CPAN::Forum
|
---|
338 |
|
---|
339 | The CPAN Forum is a web forum for discussing Perl's CPAN modules. The Test::Exception forum can be found at L<http://www.cpanforum.com/dist/Test-Exception>.
|
---|
340 |
|
---|
341 | =item AnnoCPAN
|
---|
342 |
|
---|
343 | AnnoCPAN is a web site that allows community annotations of Perl module documentation. The Test::Exception annotations can be found at L<http://annocpan.org/~ADIE/Test-Exception/>.
|
---|
344 |
|
---|
345 | =back
|
---|
346 |
|
---|
347 |
|
---|
348 | =head1 TO DO
|
---|
349 |
|
---|
350 | If you think this module should do something that it doesn't (or does something that it shouldn't) please let me know.
|
---|
351 |
|
---|
352 | You can see my current to do list at L<http://adrianh.tadalist.com/lists/public/15421>, with an RSS feed of changes at L<http://adrianh.tadalist.com/lists/feed_public/15421>.
|
---|
353 |
|
---|
354 |
|
---|
355 | =head1 ACKNOWLEDGMENTS
|
---|
356 |
|
---|
357 | Thanks to chromatic and Michael G Schwern for the excellent Test::Builder, without which this module wouldn't be possible.
|
---|
358 |
|
---|
359 | Thanks to
|
---|
360 | Adam Kennedy,
|
---|
361 | Andy Lester,
|
---|
362 | Aristotle,
|
---|
363 | Ben Prew,
|
---|
364 | Cees Hek,
|
---|
365 | chromatic,
|
---|
366 | Curt Sampson,
|
---|
367 | David Golden,
|
---|
368 | David Wheeler,
|
---|
369 | Janek Schleicher,
|
---|
370 | Jim Keenan,
|
---|
371 | Jos I. Boumans,
|
---|
372 | Jost Krieger,
|
---|
373 | Mark Fowler,
|
---|
374 | Michael G Schwern,
|
---|
375 | Paul McCann,
|
---|
376 | Perrin Harkins,
|
---|
377 | Peter Scott,
|
---|
378 | Rob Muhlestein
|
---|
379 | Scott R. Godin,
|
---|
380 | Steve Purkis,
|
---|
381 | Steve,
|
---|
382 | Tim Bunce,
|
---|
383 | and various anonymous folk for comments, suggestions, bug reports and patches.
|
---|
384 |
|
---|
385 |
|
---|
386 | =head1 AUTHOR
|
---|
387 |
|
---|
388 | Adrian Howard <[email protected]>
|
---|
389 |
|
---|
390 | If you can spare the time, please drop me a line if you find this module useful.
|
---|
391 |
|
---|
392 |
|
---|
393 | =head1 SEE ALSO
|
---|
394 |
|
---|
395 | =over 4
|
---|
396 |
|
---|
397 | =item L<Test::Builder>
|
---|
398 |
|
---|
399 | Support module for building test libraries.
|
---|
400 |
|
---|
401 | =item L<Test::Simple> & L<Test::More>
|
---|
402 |
|
---|
403 | Basic utilities for writing tests.
|
---|
404 |
|
---|
405 | =item L<Test::Warn> & L<Test::NoWarnings>
|
---|
406 |
|
---|
407 | Modules to help test warnings.
|
---|
408 |
|
---|
409 | =item L<http://qa.perl.org/test-modules.html>
|
---|
410 |
|
---|
411 | Overview of some of the many testing modules available on CPAN.
|
---|
412 |
|
---|
413 | =item L<http://del.icio.us/tag/Test::Exception>
|
---|
414 |
|
---|
415 | Delicious links on Test::Exception.
|
---|
416 |
|
---|
417 | =item L<http://del.icio.us/tag/perl+testing>
|
---|
418 |
|
---|
419 | Delicious links on perl testing.
|
---|
420 |
|
---|
421 | =back
|
---|
422 |
|
---|
423 |
|
---|
424 | =head1 LICENCE
|
---|
425 |
|
---|
426 | Copyright 2002-2006 Adrian Howard, All Rights Reserved.
|
---|
427 |
|
---|
428 | This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
|
---|
429 |
|
---|
430 | =cut
|
---|
431 |
|
---|
432 | 1;
|
---|