File Coverage

blib/lib/Lexical/Failure.pm
Criterion Covered Total %
statement 124 128 96.8
branch 43 64 67.1
condition 6 15 40.0
subroutine 20 20 100.0
pod 2 2 100.0
total 195 229 85.1


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__