File Coverage

blib/lib/Test/Abortable.pm

Criterion	Covered	Total	%
statement	48	55	87.2
branch	6	14	42.8
condition	3	6	50.0
subroutine	7	7	100.0
pod	2	2	100.0
total	66	84	78.5

use strict;
use warnings;
package Test::Abortable;
# ABSTRACT: subtests that you can die your way out of ... but survive
$Test::Abortable::VERSION = '0.002';
#pod =head1 OVERVIEW
#pod
#pod Test::Abortable provides a simple system for catching some exceptions and
#pod turning them into test events.  For example, consider the code below:
#pod
#pod   use Test::More;
#pod   use Test::Abortable;
#pod
#pod   use My::API; # code under test
#pod
#pod   my $API = My::API->client;
#pod
#pod   subtest "collection distinction" => sub {
#pod     my $result = $API->do_first_thing;
#pod
#pod     is($result->documents->first->title,  "The Best Thing");
#pod     isnt($result->documents->last->title, "The Best Thing");
#pod   };
#pod
#pod   subtest "document transcendence"   => sub { ... };
#pod   subtest "semiotic multiplexing"    => sub { ... };
#pod   subtest "homoiousios type vectors" => sub { ... };
#pod
#pod   done_testing;
#pod
#pod In this code, C<< $result->documents >> is a collection.  It has a C
#pod method that will throw an exception if the collection is empty.  If that
#pod happens in our code, our test program will die and most of the other subtests
#pod won't run.  We'd rather that we only abort the I.  We could do that
#pod in a bunch of ways, like adding:
#pod
#pod   return fail("no documents in response") if $result->documents->is_empty;
#pod
#pod ...but this becomes less practical as the number of places that might throw
#pod these kinds of exceptions grows.  To minimize code that boils down to "and then
#pod stop unless it makes sense to go on," Test::Abortable provides a means to
#pod communicate, via exceptions, that the running subtest should be aborted,
#pod possibly with some test output, and that the program should then continue.
#pod
#pod Test::Abortable exports a C> routine that behaves like L
#pod Test::More|Test::More/subtest> but will handle and recover from abortable
#pod exceptions (defined below).  It also exports C>, which behaves
#pod like a block eval that only catches abortable exceptions.
#pod
#pod For an exception to be "abortable," in this sense, it must respond to a
#pod C method.  This method must return an arrayref of
#pod arrayrefs that describe the Test2 events to emit when the exception is caught.
#pod For example, the exception thrown by our sample code above might have a
#pod C method that returns:
#pod
#pod   [
#pod     [ Ok => (pass => 0, name => "->first called on empty collection") ],
#pod   ]
#pod
#pod It's permissible to have passing Ok events, or only Diag events, or multiple
#pod events, or none — although providing none might lead to some serious confusion.
#pod
#pod Right now, any exception that provides this method will be honored.  In the
#pod future, a facility for only allowing abortable exceptions of a given class may
#pod be added.
#pod
#pod =cut

use Test2::API 1.302075 (); # no_fork
use Sub::Exporter -setup => {
  exports => [ qw(subtest testeval) ],
  groups  => { default => [ qw(subtest testeval) ] },
};

#pod =func subtest
#pod
#pod   subtest "do some stuff" => sub {
#pod     do_things;
#pod     do_stuff;
#pod     do_actions;
#pod   };
#pod
#pod This routine looks just like Test::More's C and acts just like it,
#pod too, with one difference: the code item passed in is executed in a block
#pod C and any exception thrown is checked for C.  If
#pod there's no exception, it returns normally.  If there's an abortable exception,
#pod the events are sent to the test hub and the subtest finishes normally.  If
#pod there's a non-abortable exception, it is rethrown.
#pod
#pod =cut

sub subtest {
  my ($name, $code) = @_;

  my $ctx = Test2::API::context();

  my $pass = Test2::API::run_subtest($name, sub {
    my $ok = eval { $code->(); 1 };

    my $ctx = Test2::API::context();

    if (! $ok) {
      my $error = $@;
      if (ref $error and my $events = eval { $error->as_test_abort_events }) {
        for (@$events) {
          my $e = $ctx->send_event(@$_);
          $e->set_meta(test_abort_object => $error)
        }
      } else {
        $ctx->release;
        die $error;
      }
    }

    $ctx->release;

    return;
  }, { no_fork => 1 });

  $ctx->release;

  return $pass;
}

#pod =func testeval
#pod
#pod   my $result = testeval {
#pod     my $x = get_the_x;
#pod     my $y = acquire_y;
#pod     return $x * $y;
#pod   };
#pod
#pod C behaves like C, but only catches abortable exceptions.  If
#pod the code passed to C throws an abortable exception C will
#pod return false and put the exception into C<$@>.  Other exceptions are
#pod propagated.
#pod
#pod =cut

sub testeval (&) {
  my ($code) = @_;
  my $ctx = Test2::API::context();
  my @result;

  my $wa = wantarray;
  my $ok = eval {
    if    (not defined $wa) { $code->() }
    elsif (not         $wa) { @result = scalar $code->() }
    else                    { @result = $code->() }

    1;
  };

  if (! $ok) {
    my $error = $@;
    if (ref $error and my $events = eval { $error->as_test_abort_events }) {
      for (@$events) {
        my $e = $ctx->send_event(@$_);
        $e->set_meta(test_abort_object => $error)
      }

      $ctx->release;
      $@ = $error;
      return;
    } else {
      die $error;
    }
  }

  $ctx->release;
  return $wa ? @result : $result[0];
}

#pod =head1 EXCEPTION IMPLEMENTATIONS
#pod
#pod You don't need to use an exception class provided by Test::Abortable to build
#pod abortable exceptions.  This is by design.  In fact, Test::Abortable doesn't
#pod ship with any abortable exception classes at all.  You should just add a
#pod C where it's useful and appropriate.
#pod
#pod Here are two possible simple implementations of trivial abortable exception
#pod classes.  First, using plain old vanilla objects:
#pod
#pod   package Abort::Test {
#pod     sub as_test_abort_events ($self) {
#pod       return [ [ Ok => (pass => 0, name => $self->{message}) ] ];
#pod     }
#pod   }
#pod   sub abort ($message) { die bless { message => $message }, 'Abort::Test' }
#pod
#pod This works, but if those exceptions ever get caught somewhere else, you'll be
#pod in a bunch of pain because they've got no stack trace, no stringification
#pod behavior, and so on.  For a more robust but still tiny implementation, you
#pod might consider L:
#pod
#pod   use failures 'testabort';
#pod   sub failure::testabort::as_test_abort_events ($self) {
#pod     return [ [ Ok => (pass => 0, name => $self->msg) ] ];
#pod   }
#pod
#pod For whatever it's worth, the author's intent is to add C
#pod methods to his code through the use of application-specific Moose roles,
#pod
#pod =cut

1;

__END__