line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Lexical::Failure; |
2
|
|
|
|
|
|
|
|
3
|
10
|
|
|
10
|
|
140334
|
use 5.014; use warnings; |
|
10
|
|
|
10
|
|
45
|
|
|
10
|
|
|
|
|
52
|
|
|
10
|
|
|
|
|
18
|
|
|
10
|
|
|
|
|
424
|
|
4
|
10
|
|
|
10
|
|
6409
|
no if $] >= 5.018, 'warnings', "experimental"; |
|
10
|
|
|
|
|
133
|
|
|
10
|
|
|
|
|
63
|
|
5
|
10
|
|
|
10
|
|
6076
|
use Scope::Upper qw< want_at unwind uplevel CALLER UP SUB >; |
|
10
|
|
|
|
|
9682
|
|
|
10
|
|
|
|
|
765
|
|
6
|
10
|
|
|
10
|
|
72
|
use Carp qw< carp croak confess cluck >; |
|
10
|
|
|
|
|
21
|
|
|
10
|
|
|
|
|
593
|
|
7
|
10
|
|
|
10
|
|
4168
|
use Keyword::Simple; |
|
10
|
|
|
|
|
238775
|
|
|
10
|
|
|
|
|
382
|
|
8
|
10
|
|
|
10
|
|
5216
|
use Attribute::Handlers; |
|
10
|
|
|
|
|
42169
|
|
|
10
|
|
|
|
|
53
|
|
9
|
|
|
|
|
|
|
|
10
|
10
|
|
|
10
|
|
5154
|
use Lexical::Failure::Objects; |
|
10
|
|
|
|
|
26
|
|
|
10
|
|
|
|
|
13087
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our $VERSION = '0.001000'; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
# Be invisible to Carp... |
15
|
|
|
|
|
|
|
our @CARP_NOT = __PACKAGE__; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
# Lexical hints are always at index 10 of caller()... |
18
|
|
|
|
|
|
|
my $HINTS = 10; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
# How to fail... |
21
|
|
|
|
|
|
|
my %STD_FAILURE_HANDLERS = ( |
22
|
|
|
|
|
|
|
'die' => sub { _uplevel_die(@_); }, |
23
|
|
|
|
|
|
|
'croak' => sub { package Carp; uplevel { croak(@_) } @_, CALLER($Lexical::Failure::uplevel); }, |
24
|
|
|
|
|
|
|
'confess' => sub { package Carp; uplevel { confess(@_) } @_, CALLER($Lexical::Failure::uplevel); }, |
25
|
|
|
|
|
|
|
'null' => sub { return; }, |
26
|
|
|
|
|
|
|
'undef' => sub { return undef; }, |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
'failobj' => sub { |
29
|
|
|
|
|
|
|
uplevel { croak(@_) } @_, CALLER($Lexical::Failure::uplevel) if !defined wantarray; |
30
|
|
|
|
|
|
|
return Lexical::Failure::Objects->new( |
31
|
|
|
|
|
|
|
msg => (@_==1 ? $_[0] : "@_"), |
32
|
|
|
|
|
|
|
context => [caller $Lexical::Failure::uplevel], |
33
|
|
|
|
|
|
|
); |
34
|
|
|
|
|
|
|
}, |
35
|
|
|
|
|
|
|
); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# Track handlers for lexical installations of fail() |
38
|
|
|
|
|
|
|
my @ACTIVE_FAILURE_HANDLER_FOR_SCOPE; |
39
|
|
|
|
|
|
|
my @VALID_FAILURE_HANDLERS_FOR_SCOPE; |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# # 'croak' is the universal default failure handler... |
42
|
|
|
|
|
|
|
my $DEF_NAMED_HANDLER = 'croak'; |
43
|
|
|
|
|
|
|
my $DEFAULT_SCOPE_ID = 0; |
44
|
|
|
|
|
|
|
$ACTIVE_FAILURE_HANDLER_FOR_SCOPE[$DEFAULT_SCOPE_ID] = $STD_FAILURE_HANDLERS{$DEF_NAMED_HANDLER}; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# Load the module... |
47
|
|
|
|
|
|
|
sub import { |
48
|
10
|
|
|
10
|
|
113
|
my ($fail, $ON_FAILURE, $default, $handlers) = _process_import_args(@_); |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
# Export API... |
51
|
10
|
|
|
|
|
34
|
Keyword::Simple::define $ON_FAILURE, _replace_keyword_with('Lexical::Failure::ON_FAILURE'); |
52
|
10
|
|
|
|
|
262
|
Keyword::Simple::define $fail, _replace_keyword_with('Lexical::Failure::fail'); |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# Install specified failure handlers for the caller's scope... |
55
|
10
|
|
|
|
|
182
|
my $handlers_scope_ID = scalar @VALID_FAILURE_HANDLERS_FOR_SCOPE; |
56
|
10
|
|
|
|
|
41
|
$^H{'Lexical::Failure::handlers_scope_ID'} = $handlers_scope_ID; |
57
|
10
|
|
|
|
|
30
|
push @VALID_FAILURE_HANDLERS_FOR_SCOPE, { %STD_FAILURE_HANDLERS, %{$handlers} }; |
|
10
|
|
|
|
|
37
|
|
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# Install default failure handler for the caller's scope... |
60
|
10
|
50
|
|
|
|
44
|
if (ref($default) ne 'CODE') { |
61
|
|
|
|
|
|
|
croak "Unknown default failure handler: '$default'" |
62
|
10
|
50
|
|
|
|
32
|
if !exists $VALID_FAILURE_HANDLERS_FOR_SCOPE[-1]{$default}; |
63
|
10
|
|
|
|
|
21
|
$default = $VALID_FAILURE_HANDLERS_FOR_SCOPE[-1]{$default}; |
64
|
|
|
|
|
|
|
} |
65
|
10
|
|
|
|
|
18
|
my $default_scope_ID = scalar @ACTIVE_FAILURE_HANDLER_FOR_SCOPE; |
66
|
10
|
|
|
|
|
31
|
$^H{'Lexical::Failure::default_scope_ID'} = $default_scope_ID; |
67
|
10
|
|
|
|
|
20
|
push @ACTIVE_FAILURE_HANDLER_FOR_SCOPE, $default; |
68
|
|
|
|
|
|
|
|
69
|
10
|
|
|
|
|
607
|
return; |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
sub _process_import_args { |
73
|
10
|
|
|
10
|
|
22
|
my $package = shift; |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# What we're looking for (and their values if we don't find them)... |
76
|
10
|
|
|
|
|
51
|
my $fail = 'fail'; |
77
|
10
|
|
|
|
|
16
|
my $ON_FAILURE = 'ON_FAILURE'; |
78
|
10
|
|
|
|
|
17
|
my $default = 'croak'; |
79
|
10
|
|
|
|
|
19
|
my $handlers = {}; |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# Trawl through the argument list... |
82
|
10
|
|
|
|
|
47
|
while (defined( my $next_arg = shift @_)) { |
83
|
5
|
100
|
|
|
|
21
|
if ($next_arg eq 'fail') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
84
|
2
|
50
|
|
|
|
9
|
$fail = shift(@_) |
85
|
|
|
|
|
|
|
or croak "Missing rename for 'fail' in use $package"; |
86
|
2
|
50
|
|
|
|
16
|
croak "Value for 'fail' option must be a string" |
87
|
|
|
|
|
|
|
if ref $fail; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
elsif ($next_arg eq 'ON_FAILURE') { |
90
|
1
|
50
|
|
|
|
3
|
$ON_FAILURE = shift(@_) |
91
|
|
|
|
|
|
|
or croak "Missing rename for 'fail_width' in use $package"; |
92
|
1
|
50
|
|
|
|
3
|
croak "Value for 'ON_FAILURE' option must be a string" |
93
|
|
|
|
|
|
|
if ref $fail; |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
elsif ($next_arg eq 'default') { |
96
|
1
|
50
|
|
|
|
4
|
$default = shift(@_) |
97
|
|
|
|
|
|
|
or croak "Missing specification for 'default' in use $package"; |
98
|
1
|
50
|
33
|
|
|
5
|
croak "Value for 'default' option must be a string or subroutine reference" |
99
|
|
|
|
|
|
|
if ref $fail && ref $fail ne 'CODE'; |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
elsif ($next_arg eq 'handlers') { |
102
|
1
|
50
|
|
|
|
5
|
$handlers = shift(@_) |
103
|
|
|
|
|
|
|
or croak "Missing specification for 'handlers' in use $package"; |
104
|
1
|
50
|
33
|
|
|
7
|
croak "Value for 'handlers' option must be a hash reference" |
105
|
|
|
|
|
|
|
if !ref $handlers || ref $handlers ne 'HASH'; |
106
|
|
|
|
|
|
|
croak "Handlers in 'handlers' hash must all be code references" |
107
|
1
|
50
|
|
|
|
2
|
if grep { ref($_) ne 'CODE' } values %{$handlers}; |
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
3
|
|
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
else { |
110
|
0
|
|
|
|
|
0
|
croak "Unexpected argument ($next_arg) in use $package" |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
10
|
|
|
|
|
36
|
return ($fail, $ON_FAILURE, $default, $handlers); |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
sub _replace_keyword_with { |
118
|
20
|
|
|
20
|
|
37
|
my $replacement = shift; |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
return sub { |
121
|
18
|
|
|
18
|
|
69
|
my ($src_ref) = @_; |
122
|
18
|
|
|
|
|
33
|
substr(${$src_ref}, 0, 0) = $replacement; |
|
18
|
|
|
|
|
1169
|
|
123
|
|
|
|
|
|
|
} |
124
|
20
|
|
|
|
|
113
|
} |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
sub ON_FAILURE { |
127
|
40
|
|
|
40
|
1
|
68432
|
my $handler = shift; |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# No arg or undef arg --> no-op... |
130
|
40
|
100
|
|
|
|
1997
|
return if !defined $handler; |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
# Can't be called at runtime... |
133
|
36
|
100
|
|
|
|
140
|
if (${^GLOBAL_PHASE} ne 'START') { |
134
|
1
|
|
|
|
|
157
|
croak "Can't call ON_FAILURE after compilation" |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
# Can't be called outside a subroutine... |
138
|
35
|
50
|
|
|
|
188
|
if ((caller 1)[3] eq '(eval)') { |
139
|
0
|
|
|
|
|
0
|
croak "Can't call ON_FAILURE outside a subroutine" |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
# Can only be called with certain types of arguments... |
143
|
35
|
|
|
|
|
92
|
my $handler_type = ref $handler; |
144
|
35
|
50
|
|
|
|
196
|
croak "Invalid handler type ($handler_type ref) in call to ON_FAILURE" |
145
|
|
|
|
|
|
|
if $handler_type !~ m{\A (?: CODE | SCALAR | ARRAY | HASH | (?#STRING) ) \z}xms; |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
# Which package is setting this handler??? |
148
|
35
|
|
|
|
|
70
|
my $owner = caller; |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# Locate valid failure handlers... |
151
|
35
|
|
|
|
|
206
|
my $handlers_scope_ID = (caller 0)[$HINTS]{'Lexical::Failure::handlers_scope_ID'}; |
152
|
35
|
|
|
|
|
107
|
my $valid_handlers_ref = $VALID_FAILURE_HANDLERS_FOR_SCOPE[$handlers_scope_ID]; |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# Translate failure handlers (if necessary)... |
155
|
35
|
|
|
|
|
80
|
for my $type (ref $handler) { |
156
|
|
|
|
|
|
|
# Find handler for symbolic failure modes ('die', 'confess', etc.)... |
157
|
35
|
100
|
|
|
|
81
|
if ($type eq q{}) { |
158
|
|
|
|
|
|
|
croak "Unknown failure handler: '$handler'" |
159
|
20
|
50
|
|
|
|
46
|
if !exists $valid_handlers_ref->{$handler}; |
160
|
20
|
|
|
|
|
46
|
$handler = $valid_handlers_ref->{$handler}; |
161
|
20
|
|
|
|
|
38
|
last; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
15
|
|
|
|
|
24
|
my $target_var = $handler; |
165
|
|
|
|
|
|
|
# _check_scoping_of($target_var); # Experimentally removed (may not be necessary) |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# Scalars are simply assigned to... |
168
|
15
|
100
|
|
|
|
35
|
if ($type eq 'SCALAR') { |
169
|
6
|
|
|
6
|
|
22
|
$handler = sub { ${$target_var} = [@_]; return; }; |
|
6
|
|
|
|
|
17
|
|
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
42
|
|
170
|
6
|
|
|
|
|
14
|
last; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
# Arrays are simply pushed onto... |
174
|
9
|
100
|
|
|
|
23
|
if ($type eq 'ARRAY') { |
175
|
3
|
|
|
5
|
|
12
|
$handler = sub { push @{$target_var}, [@_]; return; }; |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
20
|
|
|
5
|
|
|
|
|
38
|
|
176
|
3
|
|
|
|
|
9
|
last; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
# Hashes are simply added to... |
180
|
6
|
100
|
|
|
|
18
|
if ($type eq 'HASH') { |
181
|
|
|
|
|
|
|
$handler = sub { |
182
|
3
|
|
|
3
|
|
20
|
my $caller_sub = (caller 2)[3]; |
183
|
3
|
|
|
|
|
21
|
$target_var->{$caller_sub} = [@_]; |
184
|
3
|
|
|
|
|
24
|
return; |
185
|
3
|
|
|
|
|
14
|
}; |
186
|
3
|
|
|
|
|
8
|
last; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
# Install failure handler for the scope... |
191
|
35
|
|
|
|
|
63
|
my $scope_ID = scalar @ACTIVE_FAILURE_HANDLER_FOR_SCOPE; |
192
|
35
|
|
|
|
|
180
|
$^H{"Lexical::Failure::scope_ID::$owner"} = $scope_ID; |
193
|
35
|
|
|
|
|
69
|
push @ACTIVE_FAILURE_HANDLER_FOR_SCOPE, $handler; |
194
|
|
|
|
|
|
|
|
195
|
35
|
|
|
|
|
7307
|
return; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
# Fail by calling the appropriate handler... |
199
|
|
|
|
|
|
|
sub fail { |
200
|
50
|
|
|
50
|
1
|
48775
|
my (@msg) = @_; |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# Find the requested lexical handler... |
203
|
50
|
|
|
|
|
111
|
my $caller = caller; |
204
|
50
|
|
|
|
|
135
|
my ($fail_handler, $uplevel) = _find_callers_handler($caller); |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
# Determine original context of sub that's failing... |
207
|
50
|
|
|
|
|
271
|
my $context = want_at(CALLER($uplevel-1)); |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
# Ignore this code when croaking/carping from a handler |
210
|
|
|
|
|
|
|
package |
211
|
|
|
|
|
|
|
Carp; |
212
|
10
|
|
|
10
|
|
88
|
use Scope::Upper qw< unwind CALLER UP SUB>; |
|
10
|
|
|
|
|
22
|
|
|
10
|
|
|
|
|
4308
|
|
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# Simulate a return... |
215
|
50
|
|
|
|
|
100
|
unwind +( do { |
216
|
50
|
|
|
|
|
87
|
local $Lexical::Failure::uplevel = $uplevel; |
217
|
50
|
100
|
|
|
|
234
|
!defined $context ? do{ $fail_handler->(@msg); undef; } |
|
15
|
100
|
|
|
|
60
|
|
|
0
|
|
|
|
|
0
|
|
218
|
|
|
|
|
|
|
: ! $context ? scalar $fail_handler->(@msg) |
219
|
|
|
|
|
|
|
: $fail_handler->(@msg) |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
) => CALLER($uplevel-1); |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
# Locate hints hash of first scope outside caller (if any)... |
226
|
|
|
|
|
|
|
sub _find_callers_handler { |
227
|
50
|
|
|
50
|
|
110
|
my ($immediate_caller_package) = @_; |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
# Scope ID for default handler... |
230
|
|
|
|
|
|
|
my $default_scope_ID |
231
|
50
|
|
33
|
|
|
460
|
= (caller 1)[$HINTS]{'Lexical::Failure::default_scope_ID'} |
232
|
|
|
|
|
|
|
// $DEFAULT_SCOPE_ID; |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
# Search upwards for first namespace different from $caller... |
235
|
|
|
|
|
|
|
LEVEL: |
236
|
50
|
|
|
|
|
219
|
for my $uplevel (2..10000) { |
237
|
64
|
|
|
|
|
300
|
my @uplevel_caller = caller($uplevel); |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
# Give up if no higher contexts... |
240
|
64
|
50
|
|
|
|
179
|
last LEVEL if !@uplevel_caller; |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
# Return handler for first different namespace (or else default handler)... |
243
|
64
|
100
|
|
|
|
189
|
if ($uplevel_caller[0] ne $immediate_caller_package) { |
244
|
|
|
|
|
|
|
my $target_scope_ID |
245
|
50
|
|
66
|
|
|
194
|
= $uplevel_caller[10]{"Lexical::Failure::scope_ID::$immediate_caller_package"} |
246
|
|
|
|
|
|
|
// $default_scope_ID; |
247
|
50
|
|
|
|
|
256
|
return $ACTIVE_FAILURE_HANDLER_FOR_SCOPE[ $target_scope_ID ], $uplevel; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
# If no such uplevel context, return a "null" hints hash... |
252
|
0
|
|
|
|
|
0
|
return $ACTIVE_FAILURE_HANDLER_FOR_SCOPE[ $default_scope_ID ], 0; |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
# Simulate a die() called at 2 levels higher up the stack... |
257
|
|
|
|
|
|
|
sub _uplevel_die { |
258
|
3
|
0
|
|
3
|
|
29
|
my $exception = @_ ? join(q{},@_) |
|
|
50
|
|
|
|
|
|
259
|
|
|
|
|
|
|
: $@ ? qq{$@\t...propagated} |
260
|
|
|
|
|
|
|
: q{Died}; |
261
|
|
|
|
|
|
|
|
262
|
3
|
50
|
|
|
|
15
|
die $exception if ref $exception; |
263
|
|
|
|
|
|
|
|
264
|
3
|
50
|
33
|
|
|
43
|
if (!ref $exception && substr($exception, -1) ne "\n") { |
265
|
3
|
|
|
|
|
24
|
my (undef, $file, $line) = caller(2); |
266
|
3
|
|
|
|
|
20
|
$exception .= " at $file line $line\n"; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
3
|
|
|
|
|
33
|
die $exception; |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
1; # Magic true value required at end of module |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
__END__ |