File Coverage

blib/lib/Test/Fatal.pm

Criterion	Covered	Total	%
statement	53	56	94.6
branch	13	20	65.0
condition	9	15	60.0
subroutine	12	12	100.0
pod	4	4	100.0
total	91	107	85.0

use v5.12.0;
use warnings;
package Test::Fatal 0.018;
# ABSTRACT: incredibly simple helpers for testing code with exceptions

#pod =head1 SYNOPSIS
#pod
#pod   use Test::More;
#pod   use Test::Fatal;
#pod
#pod   use System::Under::Test qw(might_die);
#pod
#pod   is(
#pod     exception { might_die; },
#pod     undef,
#pod     "the code lived",
#pod   );
#pod
#pod   like(
#pod     exception { might_die; },
#pod     qr/turns out it died/,
#pod     "the code died as expected",
#pod   );
#pod
#pod   isa_ok(
#pod     exception { might_die; },
#pod     'Exception::Whatever',
#pod     'the thrown exception',
#pod   );
#pod
#pod =head1 DESCRIPTION
#pod
#pod Test::Fatal is an alternative to the popular L.  It does much
#pod less, but should allow greater flexibility in testing exception-throwing code
#pod with about the same amount of typing.
#pod
#pod It exports one routine by default: C.
#pod
#pod B  C intentionally does not manipulate the call stack.
#pod User-written test functions that use C must be careful to avoid
#pod false positives if exceptions use stack traces that show arguments.  For a more
#pod magical approach involving globally overriding C, see
#pod L.
#pod
#pod =cut

use Carp ();
use Try::Tiny 0.07;

use Exporter 5.57 'import';

our @EXPORT    = qw(exception);
our @EXPORT_OK = qw(exception success dies_ok lives_ok);

#pod =func exception
#pod
#pod   my $exception = exception { ... };
#pod
#pod C takes a bare block of code and returns the exception thrown by
#pod that block.  If no exception was thrown, it returns undef.
#pod
#pod B  If the block results in an I exception, such as 0
#pod or the empty string, Test::Fatal itself will die.  Since either of these cases
#pod indicates a serious problem with the system under testing, this behavior is
#pod considered a I. Note that this issue is only known to occur on perls
#pod before 5.14.
#pod
#pod Exercise caution if you must test for these conditions: wrapping C
#pod ... }> in an C block will not give you the result you need, so make sure
#pod you use C instead.  You can also directly use L's try/catch
#pod mechanism, the underlying exception handling system of Test::Fatal.
#pod
#pod Note that there is no TAP assert being performed.  In other words, no "ok" or
#pod "not ok" line is emitted.  It's up to you to use the rest of C in an
#pod existing test like C, C, C, et cetera.  Or you may wish to use
#pod the C and C wrappers, which do provide TAP output.
#pod
#pod C does I alter the stack presented to the called block, meaning
#pod that if the exception returned has a stack trace, it will include some frames
#pod between the code calling C and the thing throwing the exception.
#pod This is considered a I because it avoids the occasionally twitchy
#pod C mechanism.
#pod
#pod B  This is not a great idea:
#pod
#pod   sub exception_like(&$;$) {
#pod       my ($code, $pattern, $name) = @_;
#pod       like( &exception($code), $pattern, $name );
#pod   }
#pod
#pod   exception_like(sub { }, qr/foo/, 'foo appears in the exception');
#pod
#pod If the code in the C<...> is going to throw a stack trace with the arguments to
#pod each subroutine in its call stack (for example via C,
#pod the test name, "foo appears in the exception" will itself be matched by the
#pod regex.  Instead, write this:
#pod
#pod   like( exception { ... }, qr/foo/, 'foo appears in the exception' );
#pod
#pod If you really want a test function that passes the test name, wrap the
#pod arguments in an array reference to hide the literal text from a stack trace:
#pod
#pod   sub exception_like(&$) {
#pod       my ($code, $args) = @_;
#pod       my ($pattern, $name) = @$args;
#pod       like( &exception($code), $pattern, $name );
#pod   }
#pod
#pod   exception_like(sub { }, [ qr/foo/, 'foo appears in the exception' ] );
#pod
#pod To aid in avoiding the problem where the pattern is seen in the exception
#pod because of the call stack, C<$Carp::MaxArgNums> is locally set to -1 when the
#pod code block is called.  If you really don't want that, set it back to whatever
#pod value you like at the beginning of the code block.  Obviously, this solution
#pod doens't affect all possible ways that args of subroutines in the call stack
#pod might taint the test.  The intention here is to prevent some false passes from
#pod people who didn't read the documentation.  Your punishment for reading it is
#pod that you must consider whether to do anything about this.
#pod
#pod B: One final bad idea:
#pod
#pod   isnt( exception { ... }, undef, "my code died!");
#pod
#pod It's true that this tests that your code died, but you should really test that
#pod it died I.  For example, if you make an unrelated mistake
#pod in the block, like using the wrong dereference, your test will pass even though
#pod the code to be tested isn't really run at all.  If you're expecting an
#pod inspectable exception with an identifier or class, test that.  If you're
#pod expecting a string exception, consider using C.
#pod
#pod =cut

our ($REAL_TBL, $REAL_CALCULATED_TBL) = (1, 1);

sub exception (&) {
  my $code = shift;

  return try {
    my $incremented = defined $Test::Builder::Level
                    ? $Test::Builder::Level - $REAL_CALCULATED_TBL
                    : 0;
    local $Test::Builder::Level = $REAL_CALCULATED_TBL;
    if ($incremented) {
        # each call to exception adds 5 stack frames
        $Test::Builder::Level += 5;
        for my $i (1..$incremented) {
            # -2 because we want to see it from the perspective of the call to
            # is() within the call to $code->()
            my $caller = caller($Test::Builder::Level - 2);
            if ($caller eq __PACKAGE__) {
                # each call to exception adds 5 stack frames
                $Test::Builder::Level = $Test::Builder::Level + 5;
            }
            else {
                $Test::Builder::Level = $Test::Builder::Level + 1;
            }
        }
    }

    local $REAL_CALCULATED_TBL = $Test::Builder::Level;
    local $Carp::MaxArgNums = -1;
    $code->();
    return undef;
  } catch {
    return $_ if $_ or ref; # allow objects with a false boolean overload

    my $problem = defined $_ ? 'false' : 'undef';
    Carp::confess("$problem exception caught by Test::Fatal::exception");
  };
}

#pod =func success
#pod
#pod   try {
#pod     should_live;
#pod   } catch {
#pod     fail("boo, we died");
#pod   } success {
#pod     pass("hooray, we lived");
#pod   };
#pod
#pod C, exported only by request, is a L helper with semantics
#pod identical to L|Try::Tiny/finally>, but the body of the block will
#pod only be run if the C block ran without error.
#pod
#pod Although almost any needed exception tests can be performed with C,
#pod success blocks may sometimes help organize complex testing.
#pod
#pod =cut

sub success (&;@) {
  my $code = shift;
  return finally( sub {
    return if @_; # <-- only run on success
    $code->();
  }, @_ );
}

#pod =func dies_ok
#pod
#pod =func lives_ok
#pod
#pod Exported only by request, these two functions run a given block of code, and
#pod provide TAP output indicating if it did, or did not throw an exception.
#pod These provide an easy upgrade path for replacing existing unit tests based on
#pod C.
#pod
#pod RJBS does not suggest using this except as a convenience while porting tests to
#pod use Test::Fatal's C routine.
#pod
#pod   use Test::More tests => 2;
#pod   use Test::Fatal qw(dies_ok lives_ok);
#pod
#pod   dies_ok { die "I failed" } 'code that fails';
#pod
#pod   lives_ok { return "I'm still alive" } 'code that does not fail';
#pod
#pod =cut

my $Tester;

# Signature should match that of Test::Exception
sub dies_ok (&;$) {
  my $code = shift;
  my $name = shift;

  require Test::Builder;
  $Tester ||= Test::Builder->new;

  my $tap_pos = $Tester->current_test;

  my $exception = exception( \&$code );

  $name ||= $tap_pos != $Tester->current_test
        ? "...and code should throw an exception"
        : "code should throw an exception";

  my $ok = $Tester->ok( $exception, $name );
  $ok or $Tester->diag( "expected an exception but none was raised" );
  return $ok;
}

sub lives_ok (&;$) {
  my $code = shift;
  my $name = shift;

  require Test::Builder;
  $Tester ||= Test::Builder->new;

  my $tap_pos = $Tester->current_test;

  my $exception = exception( \&$code );

  $name ||= $tap_pos != $Tester->current_test
        ? "...and code should not throw an exception"
        : "code should not throw an exception";

  my $ok = $Tester->ok( ! $exception, $name );
  $ok or $Tester->diag( "expected return but an exception was raised" );
  return $ok;
}

1;

__END__