t/Exception.pm

   1 package t::Exception;
   2 use strict;
   3 use warnings;
   4 use base qw/Exporter/;
   5
   6 our @EXPORT = qw/throws_ok lives_ok/;
   7
   8 my $Tester;
   9
  10 my $is_exception = sub {
  11     my $exception = shift;
  12     return ref $exception || $exception ne '';
  13 };
  14
  15 my $exception_as_string = sub {
  16     my ( $prefix, $exception ) = @_;
  17     return "$prefix normal exit" unless $is_exception->( $exception );
  18     my $class = ref $exception;
  19     $exception = "$class ($exception)"
  20             if $class && "$exception" !~ m/^\Q$class/;
  21     chomp $exception;
  22     return "$prefix $exception";
  23 };
  24 my $try_as_caller = sub {
  25     my $coderef = shift;
  26     eval { $coderef->() };
  27     $@;
  28 };
  29
  30 sub throws_ok (&$;$) {
  31     my ( $coderef, $expecting, $description ) = @_;
  32     Carp::croak "throws_ok: must pass exception class/object or regex"
  33         unless defined $expecting;
  34     $description = $exception_as_string->( "threw", $expecting )
  35         unless defined $description;
  36     my $exception = $try_as_caller->($coderef);
  37
  38     $Tester ||= Test::Builder->new;
  39
  40     my $regex = $Tester->maybe_regex( $expecting );
  41     my $ok = $regex
  42         ? ( $exception =~ m/$regex/ )
  43         : eval {
  44             $exception->isa( ref $expecting ? ref $expecting : $expecting )
  45         };
  46     $Tester->ok( $ok, $description );
  47     unless ( $ok ) {
  48         $Tester->diag( $exception_as_string->( "expecting:", $expecting ) );
  49         $Tester->diag( $exception_as_string->( "found:", $exception ) );
  50     };
  51     $@ = $exception;
  52     return $ok;
  53 }
  54
  55 sub lives_ok (&;$) {
  56     my ( $coderef, $description ) = @_;
  57     my $exception = $try_as_caller->( $coderef );
  58
  59     $Tester ||= Test::Builder->new;
  60
  61     my $ok = $Tester->ok( ! $is_exception->( $exception ), $description );
  62     $Tester->diag( $exception_as_string->( "died:", $exception ) ) unless $ok;
  63     $@ = $exception;
  64     return $ok;
  65 }
  66
  67 1;