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__ |