File Coverage

blib/lib/Try/Harder.pm
Criterion Covered Total %
statement 63 64 98.4
branch 15 22 68.1
condition 1 3 33.3
subroutine 14 14 100.0
pod 0 2 0.0
total 93 105 88.5


line stmt bran cond sub pod time code
1 9     9   420992 use strict;
  9         74  
  9         216  
2 9     9   37 use warnings;
  9         12  
  9         327  
3             package Try::Harder;
4              
5             # ABSTRACT: Try hard to get the functionality of Syntax::Keyword::Try
6              
7 9     9   3654 use Module::Load::Conditional qw( can_load );
  9         199609  
  9         460  
8 9     9   3193 use Import::Into;
  9         18947  
  9         216  
9              
10 9     9   53 use Carp;
  9         14  
  9         820  
11             $Carp::Internal{+__PACKAGE__}++;
12              
13             # determine if we can use Syntax::Keyword::Try or have to use the pure-perl
14             # source filtering
15             our $USE_PP;
16             BEGIN {
17             # Syntax::Keyword::Try is faster, safer, and better than the source filter
18             # in every way. If it's available, just use it and be done with all this.
19 9 50 33 9   48 if ( can_load( modules => { 'Syntax::Keyword::Try' => undef } )
20             and not $ENV{TRY_HARDER_USE_PP} ) {
21             #warn "Using Syntax::Keyword::Try\n";
22 0         0 $USE_PP = 0;
23             }
24             else {
25             #warn "Using ATHFilter\n";
26 9         4586 $USE_PP = 1;
27             }
28             }
29              
30             sub import {
31             # TODO: add option to force using a particular implementation
32             if ( ! $USE_PP ) {
33             'Syntax::Keyword::Try'->import::into( scalar caller() );
34             }
35             else {
36             # suppress warnings when user uses next/last/continue from within a
37             # try or finally block. This is probably a bad idea, but hell, this
38             # whole module is a bad idea.
39             warnings->unimport('exiting');
40             }
41             }
42              
43              
44             ### code below only needed for the source-filtering implementation
45              
46 9     9   4588 use if $USE_PP, "Filter::Simple";
  9         100  
  9         38  
47 9     9   126110 use if $USE_PP, "Text::Balanced" => qw( extract_codeblock );
  9         17  
  9         38  
48              
49             setup_filter() if $USE_PP;
50              
51             sub setup_filter {
52             # Let Filter::Simple strip out all comments and strings to make it easier
53             # to extract try/catch/finally code-blocks correctly.
54             FILTER_ONLY(
55 8     8   229332 code_no_comments => sub { $_ = munge_code( $_ ) }
56 9     9 0 61 );
57             }
58              
59             # use an object to indicate a code-block never called return. This assumes
60             # nobody will ever intentionally return this object themselves...
61             my $S = __PACKAGE__ . "::SENTINEL";
62             our $SENTINEL = bless {}, $S;
63              
64             # return val of a Try::Tiny try/catch construct gets stored here
65             # so we can return it to the caller if needed.
66             my $R = __PACKAGE__ . "::RETVAL";
67             our @RETVAL;
68              
69             # if an error is caught, stash it here to inject in the finally block
70             my $E = __PACKAGE__ . "::ERROR";
71             our $ERROR;
72              
73             # flag to set if an exception is thrown
74             my $D = __PACKAGE__ . "::DIED";
75             our $DIED;
76              
77             # wantarray context of the surrounding code
78             my $W = __PACKAGE__ . "::WANTARRAY";
79             our $WANTARRAY;
80              
81             # stash the try/catch/finally closures in these
82             my $T = __PACKAGE__ . "::TRY";
83             our $TRY;
84             my $C = __PACKAGE__ . "::CATCH";
85             our $CATCH;
86             my $F = __PACKAGE__ . "::FINALLY";
87             our $FINALLY;
88              
89             # name of the ScopeGuard object for finally functionality
90             my $G = __PACKAGE__ . "::ScopeGuard";
91              
92              
93             # stealing ideas from Try::Tiny, re-write the user's code to present the
94             # same functionality and behavior as Syntax::Keyword::Try, more or less.
95             # Note that the re-written code should take up the same number of lines
96             # as the original code, so line-numbers from warnings and such don't
97             # drive people bonkers.
98             sub munge_code {
99 62     62 0 112 my ($code_to_filter) = @_;
100 62         76 my $filtered_code = "";
101              
102             # ensure user does not use multiple catch/finally blocks.
103             # Note that try { ... } try { ... } is perfectly valid.
104 62         69 my $found_catch = 0;
105 62         70 my $found_finally = 0;
106              
107             # find try/catch/finally keywords followed by a code-block, and extract the block
108 62         185 while ( $code_to_filter =~ / ( .*? ) \b( try | catch | finally ) \s* ( [{] .* ) /msx ) {
109              
110 54         212 my ($before_kw, $kw, $after_kw) = ($1, $2, $3);
111              
112 54         141 my ($code_block, $remainder) = extract_codeblock($after_kw, "{}");
113              
114             # make sure to munge any nested try/catch blocks
115 54 50       27242 $code_block = munge_code( $code_block ) if $code_block;
116              
117             # maybe unnecessary?
118 54         170 chomp $code_block;
119              
120             # rebuild the code with our modifications...
121 54         104 $filtered_code .= $before_kw;
122              
123 54 100       144 if ( $kw eq 'try' ) {
    100          
    50          
124             # found a try block, put everything in a new scope...
125 26         31 $filtered_code .= ";{ ";
126             # wrap the try block in a do block... if we reach the end of the do block,
127             # we know return was never used in the do, so return a SENTINEL.
128 26         125 $filtered_code .= "local \$$T = sub { do $code_block; return \$$S; };";
129             }
130             elsif ( $kw eq 'catch' ) {
131 20 50       41 die "Syntax Error: Only one catch-block allowed." if $found_catch++;
132 20         50 $filtered_code .= "local \$$C = sub { do $code_block; return \$$S; };";
133             }
134             elsif ( $kw eq 'finally' ) {
135 8 50       15 die "Syntax Error: Only one finally-block allowed." if $found_finally++;
136 8         22 $filtered_code .= "local \$$F = '$G'->_new(sub $code_block, \@_); ";
137             }
138              
139             # if the remainder doesn't start with a catch or finally clause, assume
140             # that's the end and add the code that makes this monstrosity work.
141 54 100       194 if ( $remainder !~ /\A \s* ( catch | finally ) \s* [{] /msx ) {
142             # add the code all on one line to preserve the original numbering.
143 26         380 $filtered_code .=
144             # init ERROR, DIED, RETVAL, and WANTARRAY
145             "local ( \$$E, \$$D, \@$R ); local \$$W = wantarray; "
146             . "{ "
147             . "local \$@; "
148             # if an exception is thrown, value of eval will be undef, stash in DIED
149             . "\$$D = not eval { "
150             # call TRY sub in appropriate context according to value of WANTARRAY
151             # capturing the return value in RETVAL
152             . "if ( \$$W ) { \@$R = &\$$T; } elsif ( defined \$$W ) { \$$R\[0] = &\$$T; } else { &\$$T; } "
153             # return 1 if no exception is thrown
154             . "return 1; "
155             . "}; "
156             # stash any exception in ERROR
157             . "\$$E = \$@; "
158             . "}; "
159             # if DIED is true, and there's a CATCH sub, stash the ERROR in $@ and then
160             # call the CATCH sub in the apropriate context. Else, re-throw ERROR
161             . "if ( \$$D ) { "
162             . "if ( \$$C ) { "
163             . "local \$@ = \$$E; "
164             . "if ( \$$W ) { \@$R = &\$$C; } elsif ( defined \$$W ) { \$$R\[0] = &\$$C; } else { &\$$C; } "
165             . "} "
166             . "else { die \$$E } "
167             . "}; "
168             # if in current scope caller is true, and RETVAL isn't a ref or a SENTINEL, we know
169             # that return was called in the code block, so return RETVAL in the apropriate context
170             . "if ( caller() and (!ref(\$$R\[0]) or !\$$R\[0]->isa('$S')) ) { return \$$W ? \@$R : \$$R\[0]; } ";
171              
172             # close the scope opened when we first found the "try"
173 26         39 $filtered_code .= "}";
174              
175             # this try/catch/finally construct is done. reset counters.
176 26         36 $found_catch = $found_finally = 0;
177             }
178              
179             # repeat this loop on the remaining code
180 54         313 $code_to_filter = $remainder;
181             }
182              
183             # overwrite the original code with the filtered code, plus whatever was left-over
184 62         273 return $filtered_code . $code_to_filter;
185             }
186              
187              
188             {
189             package # hide from PAUSE
190             Try::Harder::ScopeGuard;
191              
192             # older versions of perl have an issue with $@ during global destruction
193 9 50   9   6006 use constant UNSTABLE_DOLLARAT => ("$]" < '5.013002') ? 1 : 0;
  9         17  
  9         1990  
194              
195             sub _new {
196 8     8   2783 shift;
197 8         26 bless [ @_ ];
198             }
199              
200             sub DESTROY {
201 8     8   179 my ($code, @args) = @{ $_[0] };
  8         36  
202             # save the current exception to make it available in the finally sub,
203             # and to restore it after the eval
204 8         14 my $err = $@;
205 8         11 local $@ if UNSTABLE_DOLLARAT;
206             eval {
207 8         8 $@ = $err;
208 8         21 $code->(@args);
209 7         28 1;
210 8 100       12 } or do {
211 1 50       20 warn
212             "Execution of finally() block $code resulted in an exception, which "
213             . '*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. '
214             . 'Your program will continue as if this event never took place. '
215             . "Original exception text follows:\n\n"
216             . (defined $@ ? $@ : '$@ left undefined...')
217             . "\n"
218             ;
219             };
220             # maybe unnecessary?
221 8         44 $@ = $err;
222             }
223             }
224              
225             1 && "This was an awful idea."; # truth
226             __END__