File Coverage

blib/lib/Try/Tiny.pm
Criterion Covered Total %
statement 74 78 94.8
branch 30 38 78.9
condition 7 15 46.6
subroutine 12 12 100.0
pod 3 3 100.0
total 126 146 86.3


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