diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 12:20:49 +0000 |
commit | 316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch) | |
tree | cb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl0/lib/Test/Exception.pm | |
parent | cd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff) |
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Test/Exception.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Test/Exception.pm | 464 |
1 files changed, 464 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Test/Exception.pm b/Master/tlpkg/tlperl0/lib/Test/Exception.pm new file mode 100755 index 00000000000..4dfafdaa159 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Test/Exception.pm @@ -0,0 +1,464 @@ +use strict; +use warnings; + +package Test::Exception; +use Test::Builder; +use Sub::Uplevel qw( uplevel ); +use base qw( Exporter ); + +our $VERSION = '0.29'; +our @EXPORT = qw(dies_ok lives_ok throws_ok lives_and); + +my $Tester = Test::Builder->new; + +sub import { + my $self = shift; + if ( @_ ) { + my $package = caller; + $Tester->exported_to( $package ); + $Tester->plan( @_ ); + }; + $self->export_to_level( 1, $self, $_ ) foreach @EXPORT; +} + +=head1 NAME + +Test::Exception - Test exception based code + +=head1 SYNOPSIS + + use Test::More tests => 5; + use Test::Exception; + + # or if you don't need Test::More + + use Test::Exception tests => 5; + + # then... + + # Check that the stringified exception matches given regex + throws_ok { $foo->method } qr/division by zero/, 'zero caught okay'; + + # Check an exception of the given class (or subclass) is thrown + throws_ok { $foo->method } 'Error::Simple', 'simple error thrown'; + + # all Test::Exceptions subroutines are guaranteed to preserve the state + # of $@ so you can do things like this after throws_ok and dies_ok + like $@, 'what the stringified exception should look like'; + + # Check that something died - we do not care why + dies_ok { $foo->method } 'expecting to die'; + + # Check that something did not die + lives_ok { $foo->method } 'expecting to live'; + + # Check that a test runs without an exception + lives_and { is $foo->method, 42 } 'method is 42'; + + # or if you don't like prototyped functions + + throws_ok( sub { $foo->method }, qr/division by zero/, + 'zero caught okay' ); + throws_ok( sub { $foo->method }, 'Error::Simple', + 'simple error thrown' ); + dies_ok( sub { $foo->method }, 'expecting to die' ); + lives_ok( sub { $foo->method }, 'expecting to live' ); + lives_and( sub { is $foo->method, 42 }, 'method is 42' ); + + +=head1 DESCRIPTION + +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. + +If you are not already familiar with L<Test::More> now would be the time to go take a look. + +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. + +NOTE: Test::Exception only checks for exceptions. It will ignore other methods of stopping +program execution - including exit(). If you have an exit() in evalled code Test::Exception +will not catch this with any of its testing functions. + +=cut + +sub _quiet_caller (;$) { ## no critic Prototypes + my $height = $_[0]; + $height++; + if( wantarray and !@_ ) { + return (CORE::caller($height))[0..2]; + } + else { + return CORE::caller($height); + } +} + +sub _try_as_caller { + my $coderef = shift; + + # local works here because Sub::Uplevel has already overridden caller + local *CORE::GLOBAL::caller; + { no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; } + + eval { uplevel 3, $coderef }; + return $@; +}; + + +sub _is_exception { + my $exception = shift; + return ref $exception || $exception ne ''; +}; + + +sub _exception_as_string { + my ( $prefix, $exception ) = @_; + return "$prefix normal exit" unless _is_exception( $exception ); + my $class = ref $exception; + $exception = "$class ($exception)" + if $class && "$exception" !~ m/^\Q$class/; + chomp $exception; + return "$prefix $exception"; +}; + + +=over 4 + +=item B<throws_ok> + +Tests to see that a specific exception is thrown. throws_ok() has two forms: + + throws_ok BLOCK REGEX, TEST_DESCRIPTION + throws_ok BLOCK CLASS, TEST_DESCRIPTION + +In the first form the test passes if the stringified exception matches the give regular expression. For example: + + throws_ok { read_file( 'unreadable' ) } qr/No file/, 'no file'; + +If your perl does not support C<qr//> you can also pass a regex-like string, for example: + + throws_ok { read_file( 'unreadable' ) } '/No file/', 'no file'; + +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: + + throws_ok { $foo->bar } "Error::Simple", 'simple error'; + +Will only pass if the C<bar> method throws an Error::Simple exception, or a subclass of an Error::Simple exception. + +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: + + my $SIMPLE = Error::Simple->new; + throws_ok { $foo->bar } $SIMPLE, 'simple error'; + +Should a throws_ok() test fail it produces appropriate diagnostic messages. For example: + + not ok 3 - simple error + # Failed test (test.t at line 48) + # expecting: Error::Simple exception + # found: normal exit + +Like all other Test::Exception functions you can avoid prototypes by passing a subroutine explicitly: + + throws_ok( sub {$foo->bar}, "Error::Simple", 'simple error' ); + +A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any). + +A description of the exception being checked is used if no optional test description is passed. + +=cut + + +sub throws_ok (&$;$) { + my ( $coderef, $expecting, $description ) = @_; + unless (defined $expecting) { + require Carp; + Carp::croak( "throws_ok: must pass exception class/object or regex" ); + } + $description = _exception_as_string( "threw", $expecting ) + unless defined $description; + my $exception = _try_as_caller( $coderef ); + my $regex = $Tester->maybe_regex( $expecting ); + my $ok = $regex + ? ( $exception =~ m/$regex/ ) + : eval { + $exception->isa( ref $expecting ? ref $expecting : $expecting ) + }; + $Tester->ok( $ok, $description ); + unless ( $ok ) { + $Tester->diag( _exception_as_string( "expecting:", $expecting ) ); + $Tester->diag( _exception_as_string( "found:", $exception ) ); + }; + $@ = $exception; + return $ok; +}; + + +=item B<dies_ok> + +Checks that a piece of code dies, rather than returning normally. For example: + + sub div { + my ( $a, $b ) = @_; + return $a / $b; + }; + + dies_ok { div( 1, 0 ) } 'divide by zero detected'; + + # or if you don't like prototypes + dies_ok( sub { div( 1, 0 ) }, 'divide by zero detected' ); + +A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any). + +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(). + +The test description is optional, but recommended. + +=cut + +sub dies_ok (&;$) { + my ( $coderef, $description ) = @_; + my $exception = _try_as_caller( $coderef ); + my $ok = $Tester->ok( _is_exception($exception), $description ); + $@ = $exception; + return $ok; +} + + +=item B<lives_ok> + +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: + + sub read_file { + my $file = shift; + local $/; + open my $fh, '<', $file or die "open failed ($!)\n"; + $file = <FILE>; + return $file; + }; + + my $file; + lives_ok { $file = read_file('test.txt') } 'file read'; + + # or if you don't like prototypes + lives_ok( sub { $file = read_file('test.txt') }, 'file read' ); + +Should a lives_ok() test fail it produces appropriate diagnostic messages. For example: + + not ok 1 - file read + # Failed test (test.t at line 15) + # died: open failed (No such file or directory) + +A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any). + +The test description is optional, but recommended. + +=cut + +sub lives_ok (&;$) { + my ( $coderef, $description ) = @_; + my $exception = _try_as_caller( $coderef ); + my $ok = $Tester->ok( ! _is_exception( $exception ), $description ); + $Tester->diag( _exception_as_string( "died:", $exception ) ) unless $ok; + $@ = $exception; + return $ok; +} + + +=item B<lives_and> + +Run a test that may throw an exception. For example, instead of doing: + + my $file; + lives_ok { $file = read_file('answer.txt') } 'read_file worked'; + is $file, "42", 'answer was 42'; + +You can use lives_and() like this: + + lives_and { is read_file('answer.txt'), "42" } 'answer is 42'; + # or if you don't like prototypes + lives_and(sub {is read_file('answer.txt'), "42"}, 'answer is 42'); + +Which is the same as doing + + is read_file('answer.txt'), "42\n", 'answer is 42'; + +unless C<read_file('answer.txt')> dies, in which case you get the same kind of error as lives_ok() + + not ok 1 - answer is 42 + # Failed test (test.t at line 15) + # died: open failed (No such file or directory) + +A true value is returned if the test succeeds, false otherwise. On exit $@ is guaranteed to be the cause of death (if any). + +The test description is optional, but recommended. + +=cut + +sub lives_and (&;$) { + my ( $test, $description ) = @_; + { + local $Test::Builder::Level = $Test::Builder::Level + 1; + my $ok = \&Test::Builder::ok; + no warnings; + local *Test::Builder::ok = sub { + $_[2] = $description unless defined $_[2]; + $ok->(@_); + }; + use warnings; + eval { $test->() } and return 1; + }; + my $exception = $@; + if ( _is_exception( $exception ) ) { + $Tester->ok( 0, $description ); + $Tester->diag( _exception_as_string( "died:", $exception ) ); + }; + $@ = $exception; + return; +} + +=back + + +=head1 SKIPPING TEST::EXCEPTION TESTS + +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: + + use strict; + use warnings; + use Test::More; + + BEGIN { + eval "use Test::Exception"; + plan skip_all => "Test::Exception needed" if $@; + } + + plan tests => 2; + # ... tests that need Test::Exception ... + +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. + + +=head1 BUGS + +There are some edge cases in Perl's exception handling where Test::Exception will miss exceptions +thrown in DESTROY blocks. See the RT bug L<http://rt.cpan.org/Ticket/Display.html?id=24678> for +details, along with the t/edge-cases.t in the distribution test suite. These will be addressed in +a future Test::Exception release. + +If you find any more bugs please let me know by e-mail, or report the problem with +L<http://rt.cpan.org/>. + + +=head1 COMMUNITY + +=over 4 + +=item perl-qa + +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. + +=item perlmonks + +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. + +=item CPAN::Forum + +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>. + +=item AnnoCPAN + +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/>. + +=back + + +=head1 TO DO + +If you think this module should do something that it doesn't (or does something that it shouldn't) please let me know. + +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>. + + +=head1 ACKNOWLEDGMENTS + +Thanks to chromatic and Michael G Schwern for the excellent Test::Builder, without which this module wouldn't be possible. + +Thanks to +Adam Kennedy, +Andy Lester, +Aristotle Pagaltzis, +Ben Prew, +Cees Hek, +Chris Dolan, +chromatic, +Curt Sampson, +David Cantrell, +David Golden, +David Wheeler, +Janek Schleicher, +Jim Keenan, +Jos I. Boumans, +Joshua ben Jore, +Jost Krieger, +Mark Fowler, +Michael G Schwern, +Nadim Khemir, +Paul McCann, +Perrin Harkins, +Peter Scott, +Ricardo Signes, +Rob Muhlestein +Scott R. Godin, +Steve Purkis, +Steve, +Tim Bunce, +and various anonymous folk for comments, suggestions, bug reports and patches. + + +=head1 AUTHOR + +Adrian Howard <adrianh@quietstars.com> + +If you can spare the time, please drop me a line if you find this module useful. + + +=head1 SEE ALSO + +=over 4 + +=item L<http://del.icio.us/tag/Test::Exception> + +Delicious links on Test::Exception. + +=item L<Test::Warn> & L<Test::NoWarnings> + +Modules to help test warnings. + +=item L<Test::Builder> + +Support module for building test libraries. + +=item L<Test::Simple> & L<Test::More> + +Basic utilities for writing tests. + +=item L<http://qa.perl.org/test-modules.html> + +Overview of some of the many testing modules available on CPAN. + +=item L<http://del.icio.us/tag/perl+testing> + +Delicious links on perl testing. + +=back + + +=head1 LICENCE + +Copyright 2002-2007 Adrian Howard, All Rights Reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1; |