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