view release on metacpan or  search on metacpan

local/lib/perl5/Test/Exception.pm  view on Meta::CPAN

  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.

NOTE: This module uses L<Sub::Uplevel> and relies on overriding
C<CORE::GLOBAL::caller> to hide your test blocks from the call stack.  If this
use of global overrides concerns you, the L<Test::Fatal> module offers a more
minimalist alternative.

=cut

sub _quiet_caller (;$) { ## no critic Prototypes
    my $height = $_[0];
    $height++;

    if ( CORE::caller() eq 'DB' ) {
        # passthrough the @DB::args trick
        package DB;
        if( wantarray ) {
            if ( !@_ ) {
                return (CORE::caller($height))[0..2];
            }
            else {
                # If we got here, we are within a Test::Exception test, and
                # something is producing a stacktrace. In case this is a full
                # trace (i.e. confess() ), we have to make sure that the sub
                # args are not visible. If we do not do this, and the test in
                # question is throws_ok() with a regex, it will end up matching
                # against itself in the args to throws_ok().
                #
                # While it is possible (and maybe wise), to test if we are
                # indeed running under throws_ok (by crawling the stack right
                # up from here), the old behavior of Test::Exception was to
                # simply obliterate @DB::args altogether in _quiet_caller, so
                # we are just preserving the behavior to avoid surprises
                #
                my @frame_info = CORE::caller($height);
                @DB::args = ();
                return @frame_info;
            }
        }

        # fallback if nothing above returns
        return CORE::caller($height);
    }
    else {
        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.

NOTE: Remember when you C<die $string_without_a_trailing_newline> perl will 
automatically add the current script line number, input line number and a newline. This will
form part of the string that throws_ok regular expressions match against.


=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 ) = @_;
    {
        my $ok = \&Test::Builder::ok;
        no warnings;
        local *Test::Builder::ok = sub {
            local $Test::Builder::Level = $Test::Builder::Level + 1;
            $_[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