File Coverage

inc/Try/Tiny.pm
Criterion Covered Total %
statement 49 72 68.0
branch 10 34 29.4
condition n/a
subroutine 12 15 80.0
pod 3 3 100.0
total 74 124 59.6


line stmt bran cond sub pod time code
1             package Try::Tiny;
2             BEGIN {
3 6     6   266 $Try::Tiny::AUTHORITY = 'cpan:NUFFIN';
4             }
5             $Try::Tiny::VERSION = '0.21';
6 6     6   150 use 5.006;
  6         21  
7             # ABSTRACT: minimal try/catch with proper preservation of $@
8              
9 6     6   34 use strict;
  6         56  
  6         149  
10 6     6   30 use warnings;
  6         11  
  6         184  
11              
12 6     6   34 use Exporter ();
  6         12  
  6         337  
13             our @ISA = qw( Exporter );
14             our @EXPORT = our @EXPORT_OK = qw(try catch finally);
15              
16 6     6   36 use Carp;
  6         19  
  6         724  
17             $Carp::Internal{+__PACKAGE__}++;
18              
19 6 50   6   429 BEGIN { eval "use Sub::Name; 1" or *{subname} = sub {1} }
  34     6   40  
  6     34   4327  
  0         0  
  0         0  
20              
21             # Need to prototype as @ not $$ because of the way Perl evaluates the prototype.
22             # Keeping it at $$ means you only ever get 1 sub because we need to eval in a list
23             # context & not a scalar one
24              
25             sub try (&;@) {
26 17     17 1 57 my ( $try, @code_refs ) = @_;
27              
28             # we need to save this here, the eval block will be in scalar context due
29             # to $failed
30 17         35 my $wantarray = wantarray;
31              
32             # work around perl bug by explicitly initializing these, due to the likelyhood
33             # this will be used in global destruction (perl rt#119311)
34 17         29 my ( $catch, @finally ) = ();
35              
36             # find labeled blocks in the argument list.
37             # catch and finally tag the blocks by blessing a scalar reference to them.
38 17         35 foreach my $code_ref (@code_refs) {
39              
40 17 50       55 if ( ref($code_ref) eq 'Try::Tiny::Catch' ) {
    0          
41 17 50       35 croak 'A try() may not be followed by multiple catch() blocks'
42             if $catch;
43 17         23 $catch = ${$code_ref};
  17         38  
44             } elsif ( ref($code_ref) eq 'Try::Tiny::Finally' ) {
45 0         0 push @finally, ${$code_ref};
  0         0  
46             } else {
47 0 0       0 croak(
48             'try() encountered an unexpected argument ('
49             . ( defined $code_ref ? $code_ref : 'undef' )
50             . ') - perhaps a missing semi-colon before or'
51             );
52             }
53             }
54              
55             # FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
56             # not perfect, but we could provide a list of additional errors for
57             # $catch->();
58              
59             # name the blocks if we have Sub::Name installed
60 17         35 my $caller = caller;
61 17         63 subname("${caller}::try {...} " => $try);
62 17 50       74 subname("${caller}::catch {...} " => $catch) if $catch;
63 17         38 subname("${caller}::finally {...} " => $_) foreach @finally;
64              
65             # save the value of $@ so we can set $@ back to it in the beginning of the eval
66             # and restore $@ after the eval finishes
67 17         23 my $prev_error = $@;
68              
69 17         27 my ( @ret, $error );
70              
71             # failed will be true if the eval dies, because 1 will not be returned
72             # from the eval body
73 17         26 my $failed = not eval {
74 17         33 $@ = $prev_error;
75              
76             # evaluate the try block in the correct context
77 17 50       46 if ( $wantarray ) {
    50          
78 0         0 @ret = $try->();
79             } elsif ( defined $wantarray ) {
80 17         43 $ret[0] = $try->();
81             } else {
82 0         0 $try->();
83             };
84              
85 0         0 return 1; # properly set $fail to false
86             };
87              
88             # preserve the current error and reset the original value of $@
89 17         1625 $error = $@;
90 17         31 $@ = $prev_error;
91              
92             # set up a scope guard to invoke the finally block at the end
93             my @guards =
94 17 0       35 map { Try::Tiny::ScopeGuard->_new($_, $failed ? $error : ()) }
  0         0  
95             @finally;
96              
97             # at this point $failed contains a true value if the eval died, even if some
98             # destructor overwrote $@ as the eval was unwinding.
99 17 50       40 if ( $failed ) {
100             # if we got an error, invoke the catch block.
101 17 50       44 if ( $catch ) {
102             # This works like given($error), but is backwards compatible and
103             # sets $_ in the dynamic scope for the body of C<$catch>
104 17         32 for ($error) {
105 17         48 return $catch->($error);
106             }
107              
108             # in case when() was used without an explicit return, the C
109             # loop will be aborted and there's no useful return value
110             }
111              
112 0         0 return;
113             } else {
114             # no failure, $@ is back to what it was, everything is fine
115 0 0       0 return $wantarray ? @ret : $ret[0];
116             }
117             }
118              
119             sub catch (&;@) {
120 17     17 1 69 my ( $block, @rest ) = @_;
121              
122 17 50       67 croak 'Useless bare catch()' unless wantarray;
123              
124             return (
125 17         86 bless(\$block, 'Try::Tiny::Catch'),
126             @rest,
127             );
128             }
129              
130             sub finally (&;@) {
131 0     0 1   my ( $block, @rest ) = @_;
132              
133 0 0         croak 'Useless bare finally()' unless wantarray;
134              
135             return (
136 0           bless(\$block, 'Try::Tiny::Finally'),
137             @rest,
138             );
139             }
140              
141             {
142             package # hide from PAUSE
143             Try::Tiny::ScopeGuard;
144              
145 6 50   6   82 use constant UNSTABLE_DOLLARAT => ($] < '5.013002') ? 1 : 0;
  6         19  
  6         1693  
146              
147             sub _new {
148 0     0     shift;
149 0           bless [ @_ ];
150             }
151              
152             sub DESTROY {
153 0     0     my ($code, @args) = @{ $_[0] };
  0            
154              
155 0           local $@ if UNSTABLE_DOLLARAT;
156             eval {
157 0           $code->(@args);
158 0           1;
159 0 0         } or do {
160 0 0         warn
161             "Execution of finally() block $code resulted in an exception, which "
162             . '*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. '
163             . 'Your program will continue as if this event never took place. '
164             . "Original exception text follows:\n\n"
165             . (defined $@ ? $@ : '$@ left undefined...')
166             . "\n"
167             ;
168             }
169             }
170             }
171              
172             __PACKAGE__
173              
174             __END__