File Coverage

blib/lib/Test/Exception/LessClever.pm
Criterion Covered Total %
statement 50 51 98.0
branch 17 18 94.4
condition 2 2 100.0
subroutine 10 10 100.0
pod 5 5 100.0
total 84 86 97.6


line stmt bran cond sub pod time code
1             package Test::Exception::LessClever;
2 1     1   79359 use strict;
  1         2  
  1         28  
3 1     1   4 use warnings;
  1         1  
  1         24  
4              
5 1     1   3 use base 'Exporter';
  1         6  
  1         72  
6 1     1   5 use Test::Builder;
  1         1  
  1         19  
7 1     1   2 use Carp qw/carp/;
  1         1  
  1         1351  
8              
9             #{{{ POD
10              
11             =head1 NAME
12              
13             Test::Exception::LessClever - Test::Exception simplified ***(DEPRECATED)***
14              
15             =head1 DESCRIPTION
16              
17             *** This is deprecated please do not use it ***
18              
19             An alternative to L that is much simpler. This alternative
20             does not use fancy stack tricks to hide itself. The idea here is to keep it
21             simple. This also solves the Test::Exception bug where some dies will be hidden
22             when a DESTROY method calls eval. If a DESTROY method masks $@ a warning will
23             be generated as well.
24              
25             =head1 WHY REWRITE TEST-EXCEPTION
26              
27             Here is an IRC log.
28              
29             wtf? Bizarre copy of HASH in sassign at /usr/lib64/perl5/5.10.1/Carp/Heavy.pm line 104
30             hmm, it doesn't happen when I step through the debugger, that sure is helpful yessir
31             hmm, throws_ok or dies_ok { stuff that croaks in a package used by the one being tested }, at least in this case causes that error. If I change it to eval {}; ok( $@ ); like( $@, qr// ); it works fine
32             Ah-Ha, earlier when I mentioned I stopped using throws_ok because of something I could not remember, this was it, I stumbled on it again!
33             probably because throws_ok tries to do clever things to fiddle with the call stack to make it appear as though its guts are not being called
34             less clever would be more useful
35              
36             =head1 SYNOPSYS
37              
38             Pretty much a clone of L Refer to those docs for more details.
39              
40             use Test::More;
41             use Test::Exception;
42              
43             dies_ok { die( 'xxx' )} "Should die";
44             lives_ok { 1 } "Should live";
45             throws_ok { die( 'xxx' )} qr/xxx/, "Throws 'xxx'";
46             lives_and { ok( 1, "We did not die" )} "Ooops we died";
47              
48             done_testing;
49              
50             =head1 EXPORTABLE FUNCTIONS
51              
52             =over 4
53              
54             =cut
55              
56             #}}}
57              
58             our @EXPORT_OK = qw/live_or_die/;
59             our @EXPORT = qw/lives_ok dies_ok throws_ok lives_and/;
60             our @CARP_NOT = ( __PACKAGE__ );
61             our $TB = Test::Builder->new;
62             our $VERSION = "0.008";
63              
64             =item $status = live_or_die( sub { ... }, $name )
65              
66             =item ($status, $msg) = live_or_die( sub { ... }, $name )
67              
68             Check if the code lives or dies. In scalar context returns true or false. In
69             array context returns the same true or false with the error message. If the
70             return is true the error message will be something along the lines of 'did not
71             die' but this may change in the future.
72              
73             Will generate a warning if the test dies, $@ is empty AND called in array
74             context. This usually occurs when an objects DESTROY method calls eval and
75             masks $@.
76              
77             *NOT EXPORTED BY DEFAULT*
78              
79             =cut
80              
81             sub live_or_die {
82 13     13 1 1442 my ( $code ) = @_;
83 13   100     13 my $return = eval { $code->(); 'did not die' } || "died";
84 13         87 my $msg = $@;
85              
86 13 100       24 if ( $return eq 'did not die' ) {
87 6 100       16 return ( 1, $return ) if wantarray;
88 3         6 return 1;
89             }
90             else {
91 7 100       19 return 0 unless wantarray;
92              
93 4 50       10 if ( !$msg ) {
94 0         0 carp "code died as expected, however the error is masked. This"
95             . " can occur when an object's DESTROY() method calls eval";
96             }
97              
98 4         12 return ( 0, $msg );
99             }
100             }
101              
102             =item lives_ok( sub { ... }, $name )
103              
104             Test passes if the sub does not die, false if it does.
105              
106             =cut
107              
108             sub lives_ok(&;$) {
109 2     2 1 754 my ( $code, $name ) = @_;
110 2         6 my $ok = live_or_die( $code );
111 2         5 $TB->ok( $ok, $name );
112 2         548 return $ok;
113             }
114              
115             =item dies_ok( sub { ... }, $name )
116              
117             Test passes if the sub dies, false if it does not.
118              
119             =cut
120              
121             sub dies_ok(&;$) {
122 2     2 1 102 my ( $code, $name ) = @_;
123 2         5 my $ok = live_or_die( $code );
124 2         8 $TB->ok( !$ok, $name );
125 2         698 return !$ok;
126             }
127              
128             =item throws_ok( sub { ... }, qr/message/, $name )
129              
130             Check that the sub dies, and that it throws an error that matches the regex.
131              
132             Test fails is the sub does not die, or if the message does not match the regex.
133              
134             =cut
135              
136             sub throws_ok(&$;$) {
137 3     3 1 567 my ( $code, $reg, $name ) = @_;
138 3         4 my ( $ok, $msg ) = live_or_die( $code );
139 3         6 my ( $pkg, $file, $number ) = caller;
140              
141             # If we lived
142 3 100       8 if ( $ok ) {
143 1         6 $TB->diag( "Test did not die as expected at $file line $number." );
144 1         59 return $TB->ok( !$ok, $name );
145             }
146              
147 2 100       12 my $match = $msg =~ $reg ? 1 : 0;
148 2         5 $TB->ok( $match, $name );
149              
150 2 100       547 $TB->diag( "$file line $number:\n Wanted: $reg\n Got: $msg" )
151             unless( $match );
152              
153 2         59 return $match;
154             }
155              
156             =item lives_and( sub {...}, $name )
157              
158             Fails with $name if the sub dies, otherwise is passive. This is useful for
159             running a test that could die. If it dies there is a failure, if it lives it is
160             responsible for itself.
161              
162             =cut
163              
164             sub lives_and(&;$) {
165 2     2 1 82 my ( $code, $name ) = @_;
166 2         5 my ( $ok, $msg )= live_or_die( $code );
167 2         5 my ( $pkg, $file, $number ) = caller;
168 2         5 chomp( $msg );
169 2         3 $msg =~ s/\n/ /g;
170 2 100       10 $TB->diag( "Test unexpectedly died: '$msg' at $file line $number." ) unless $ok;
171 2 100       68 $TB->ok( $ok, $name ) if !$ok;
172 2         385 return $ok;
173             }
174              
175             1;
176              
177             __END__