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