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