Commit | Line | Data |
3118622d |
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; |