File Coverage

blib/lib/Contextual/Return.pm
Criterion Covered Total %
statement 782 1090 71.7
branch 305 558 54.6
condition 74 169 43.7
subroutine 81 94 86.1
pod 5 6 83.3
total 1247 1917 65.0


line stmt bran cond sub pod time code
1             package Contextual::Return;
2 31     31   60510 use warnings;
  31         42  
  31         913  
3 31     31   212 use strict;
  31         35  
  31         1257  
4             our $VERSION = '0.004011';
5              
6             my %attrs_of;
7              
8             # This is localized as caller to hide the interim blocks...
9             my $smart_caller;
10              
11             # Fake out Carp::*, and Scalar::Util::blessed() very early...
12             BEGIN {
13 31     31   105 no warnings 'redefine';
  31         34  
  31         9293  
14              
15 31     31   82 my $fallback_caller = *CORE::GLOBAL::caller{CODE};
16 31 50       102 if (!defined $fallback_caller) {
17             *CORE::GLOBAL::caller = sub (;$) {
18 142     142   706728 my ($height) = @_;
19 142         227 $height++;
20 142         907 my @caller = CORE::caller($height);
21 142 100       582 if ( CORE::caller() eq 'DB' ) {
22             # Oops, redo picking up @DB::args
23             package DB;
24 7         30 @caller = CORE::caller($height);
25             }
26              
27 142 100       439 return if ! @caller; # empty
28 141 100       721 return $caller[0] if ! wantarray; # scalar context
29 88 100       931 return @_ ? @caller : @caller[0..2]; # extra info or regular
30 31         151 };
31             }
32             $smart_caller = sub (;$) {
33 35   100     412 my ($uplevels) = $_[0] || 0;
34 35         31 my @caller;
35 35 100       75 if (CORE::caller eq 'DB') {
36             package DB;
37 18 50       26 if ($fallback_caller) {
38 0 0       0 @caller = $fallback_caller->($uplevels + 5 + $Contextual::Return::uplevel)
39             if $Contextual::Return::uplevel;
40 0         0 @caller = $fallback_caller->($uplevels + 4);
41             }
42             else {
43 18 50       51 @caller = CORE::caller($uplevels + 5 + $Contextual::Return::uplevel)
44             if $Contextual::Return::uplevel;
45 18         84 @caller = CORE::caller($uplevels + 4);
46             }
47             }
48             else {
49 17 50       38 if ($fallback_caller) {
50 0 0       0 @caller = $fallback_caller->($uplevels + 5 + $Contextual::Return::uplevel)
51             if $Contextual::Return::uplevel;
52 0         0 @caller = $fallback_caller->($uplevels + 4);
53             }
54             else {
55 17 50       60 @caller = CORE::caller($uplevels + 5 + $Contextual::Return::uplevel)
56             if $Contextual::Return::uplevel;
57 17         93 @caller = CORE::caller($uplevels + 4);
58             }
59             }
60 35 100       192 return if ! @caller; # empty
61 29 100       110 return $caller[0] if ! wantarray; # scalar context
62 24 100       657 return @_ ? @caller : @caller[0..2]; # extra info or regular
63 31         133 };
64              
65 31     31   134 use Carp;
  31         34  
  31         5083  
66 31         51 my $real_carp = *Carp::carp{CODE};
67 31         35 my $real_croak = *Carp::croak{CODE};
68              
69             *Carp::carp = sub {
70 1 50   1   106 goto &{$real_carp} if !$Contextual::Return::uplevel;
  1         16  
71 0         0 warn _in_context(@_);
72 31         141 };
73              
74             *Carp::croak = sub {
75 6 100   6   19 goto &{$real_croak} if !$Contextual::Return::uplevel;
  2         29  
76 4         8 die _in_context(@_);
77 31         88 };
78              
79             # Scalar::Util::blessed()...
80 31     31   125 use Scalar::Util 'refaddr';
  31         43  
  31         3154  
81              
82             # Remember the current blessed()...
83 31         48 my $original_blessing = *Scalar::Util::blessed{CODE};
84              
85             # ...and replace it...
86             *Scalar::Util::blessed = sub($) {
87 31     31   126 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31     16   38  
  31         4975  
  16         45  
88              
89             # Are we operating on a CRV???
90 16   100     68 my $attrs = $attrs_of{refaddr $_[0] or q{}};
91              
92             # If not, use the original code...
93 16 100       33 goto &{$original_blessing} if !$attrs;
  2         23  
94              
95             # Does this object have a BLESSED handler???
96 14 100       33 if (exists $attrs->{BLESSED}) {
97 2         4 return $attrs->{BLESSED}->(@{$attrs->{args}});
  2         8  
98             }
99              
100             # Otherwise, find the appropriate scalar handler...
101             handler:
102 12         19 for my $context (qw( OBJREF LAZY REF SCALAR VALUE NONVOID DEFAULT )) {
103 68 100       176 my $handler = $attrs->{$context}
104             or next handler;
105              
106 12         14 my $obj_ref = eval { $handler->(@{$attrs->{args}}) };
  12         9  
  12         35  
107              
108 12         61 my $was_blessed = $original_blessing->($obj_ref);
109 12 100       62 return $was_blessed if $was_blessed;
110             }
111              
112             # Otherwise, simulate unblessed status...
113 6         32 return undef;
114 31         4407 };
115             }
116              
117              
118              
119             sub _in_context {
120 40     40   71 my $msg = join q{}, @_;
121              
122             # Start looking in caller...
123 40         38 my $stack_frame = 1;
124 40         142 my ($package, $file, $line, $sub) = CORE::caller($stack_frame++);
125              
126 40         82 my ($orig_package, $prev_package) = ($package) x 2;
127 40         63 my $LOC = qq{at $file line $line};
128              
129             # Walk up stack...
130             STACK_FRAME:
131 40         48 while (1) {
132 141         352 my ($package, $file, $line, $sub) = CORE::caller($stack_frame++);
133              
134             # Fall off the top of the stack...
135 141 100       280 last STACK_FRAME if !defined $package;
136              
137             # Ignore this module (and any helpers)...
138 123 100       221 next STACK_FRAME if $package =~ m{^Contextual::Return}xms;
139              
140             # Track the call up the stack...
141 100         130 $LOC = qq{at $file line $line};
142              
143             # Ignore any @CARP_NOT'ed packages
144             next STACK_FRAME
145 31 100   31   134 if do { no strict 'refs'; *{$package.'::CARP_NOT'}{ARRAY}; };
  31         35  
  31         9810  
  100         74  
  100         63  
  100         296  
146              
147             # Ignore transitions within original caller...
148             next STACK_FRAME
149 70 100 66     230 if $package eq $orig_package && $prev_package eq $orig_package;
150              
151             # If we get a transition out of the original package, we're there...
152 22         26 last STACK_FRAME;
153             }
154              
155             # Insert location details...
156 40 100       424 $msg =~ s//$LOC/g or $msg =~ s/[^\S\n]*$/ $LOC/;
157 40         110 $msg =~ s/$/\n/;
158 40         172 return $msg;
159             }
160              
161             # Indentation corresponds to inherited fall-back relationships...
162             my @CONTEXTS = qw(
163             DEFAULT
164             VOID
165             NONVOID
166             LIST
167             SCALAR
168             VALUE
169             STR
170             NUM
171             BOOL
172             PUREBOOL
173             REF
174             SCALARREF
175             ARRAYREF
176             CODEREF
177             HASHREF
178             GLOBREF
179             OBJREF
180             METHOD
181             BLESSED
182             );
183              
184             my @ALL_EXPORTS = (
185             @CONTEXTS,
186             qw(
187             LAZY RESULT RVALUE METHOD FAIL
188             FIXED RECOVER LVALUE RETOBJ FAIL_WITH
189             ACTIVE CLEANUP NVALUE STRICT BLESSED
190             )
191             );
192              
193             my %STD_NAME_FOR = map { $_ => $_ } @ALL_EXPORTS;
194              
195             sub import {
196             # Load utility module for failure handlers...
197 68 50   68   17025 if (require Contextual::Return::Failure) {
198 68         194 *FAIL = \&Contextual::Return::Failure::_FAIL;
199 68         122 *FAIL_WITH = \&Contextual::Return::Failure::_FAIL_WITH;
200             }
201              
202             # Don't need the package name...
203 68         105 shift @_;
204              
205             # If args, export nothing by default; otherwise export all...
206 68 100       972 my %exports = @_ ? () : %STD_NAME_FOR;
207              
208             # All args are export either selectors and/or renamers...
209 68         258 while (my $selector = shift @_) {
210 15         21 my $next_arg = $_[0];
211             my $renamer = (defined $next_arg
212             && !ref $next_arg
213 15 100 100     91 && !exists $STD_NAME_FOR{$next_arg})
214             ? shift(@_)
215             : undef;
216 15         53 %exports = (%exports, _add_exports_for($selector, $renamer));
217             }
218              
219             # Loop through possible exports, exporting anything requested...
220 66         116 my $caller = CORE::caller;
221             EXPORT:
222 66         317 for my $subname (keys %exports) {
223 31     31   127 no strict qw( refs );
  31         40  
  31         5059  
224 1992         1202 *{$caller.'::'.$exports{$subname}} = \&{$subname};
  1992         34116  
  1992         1969  
225             }
226             };
227              
228             sub _add_exports_for {
229 15     15   19 my ($selector, $renamer) = @_;
230              
231             # If no renamer, use original name...
232 15   100     48 $renamer ||= '%s';
233              
234             # Handle different types of selector...
235 15   100     56 my $selector_type = ref($selector) || 'literal';
236              
237             # Array selector recursively export each element...
238 15 50       53 if ($selector_type eq 'ARRAY') {
    100          
    100          
239 0         0 return map { _add_exports_for($_,$renamer) } @{$selector};
  0         0  
  0         0  
240             }
241             elsif ($selector_type eq 'Regexp') {
242 4         10 my @selected = grep {/$selector/} @ALL_EXPORTS;
  136         253  
243 4 100       12 if (!@selected) {
244 1         7 Carp::carp("use Contextual::Return $selector didn't export anything");
245             }
246 31     31   17985 no if $] >= 5.022, warnings => 'redundant';
  31         244  
  31         140  
247 4         464 return map { $_ => sprintf($renamer, $_) } @selected;
  72         114  
248             }
249             elsif ($selector_type eq 'literal') {
250             Carp::croak "Can't export $selector: no such handler"
251 10 100       28 if !exists $STD_NAME_FOR{$selector};
252 31     31   3377 no if $] >= 5.022, warnings => 'redundant';
  31         39  
  31         106  
253 9         86 return ( $selector => sprintf($renamer, $selector) );
254             }
255             else {
256 1         6 Carp::croak "Can't use $selector_type as export specifier";
257             }
258             }
259              
260              
261             # Let handlers access the result object they're inside...
262              
263             sub RETOBJ() {
264 1     1 0 3 our $__RETOBJ__;
265 1         2 return $__RETOBJ__;
266             }
267              
268              
269 31     31   3576 use Scalar::Util qw( refaddr );
  31         51  
  31         4464  
270              
271             # Override return value in a C::R handler...
272             sub RESULT(;&) {
273 40     40 1 1252 my ($block) = @_;
274              
275             # Determine call context and arg list...
276 40         37 my $context;
277 40         30 my $args = do { package DB; $context=(CORE::caller 1)[5]; my $args = \@DB::args; ()=CORE::caller(1); $args };
  40         193  
  40         64  
  40         86  
  40         53  
278              
279             # No args -> return appropriate value...
280 40 100       69 if (!@_) {
281 1 0       4 return $context ? @{ $Contextual::Return::__RESULT__ || [] }
  0 50       0  
282             : $Contextual::Return::__RESULT__->[0]
283             ;
284             }
285              
286             # Hide from caller() and the enclosing eval{}...
287              
288             # Evaluate block in context and cache result...
289 39         41 local $Contextual::Return::uplevel = $Contextual::Return::uplevel+1;
290 31     31   125 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         35  
  31         4643  
  39         42  
291             $Contextual::Return::__RESULT__
292 5         14 = $context ? [ $block->(@{$args}) ]
293 33         82 : defined $context ? [ scalar $block->(@{$args}) ]
294 39 100       79 : do { $block->(@{$args}); [] }
  1 100       2  
  1         2  
  1         3  
295             ;
296              
297 39         170 return;
298             }
299              
300             sub RVALUE(&;@) :lvalue;
301             sub LVALUE(&;@) :lvalue;
302             sub NVALUE(&;@) :lvalue;
303              
304             my %opposite_of = (
305             'RVALUE' => 'LVALUE or NVALUE',
306             'LVALUE' => 'RVALUE or NVALUE',
307             'NVALUE' => 'LVALUE or RVALUE',
308             );
309              
310              
311             BEGIN {
312 31     31   82 for my $subname (qw( RVALUE LVALUE NVALUE) ) {
313 31     31   131 no strict 'refs';
  31         31  
  31         6750  
314 93         1153 *{$subname} = sub(&;@) :lvalue { # (handler, return_lvalue);
315 28     28   121 my $handler = shift;
316 28         27 my $impl;
317 28         26 my $args = do{ package DB; ()=CORE::caller(1); my $args = \@DB::args; ()=CORE::caller(1); $args };
  28         110  
  28         50  
  28         80  
  28         44  
318 28 100 33     124 if (@_==0) {
    50          
319 10         47 $impl = tie $_[0], 'Contextual::Return::Lvalue',
320             $subname => $handler, args=>$args;
321             }
322             elsif (@_==1 and $impl = tied $_[0]) {
323             die _in_context "Can't install two $subname handlers"
324 18 50       38 if exists $impl->{$subname};
325 18         29 $impl->{$subname} = $handler;
326             }
327             else {
328 0 0       0 my $vals = join q{, }, map { tied $_ ? keys %{tied $_}
  0 0       0  
  0         0  
329             : defined $_ ? $_
330             : 'undef'
331             } @_;
332 0         0 die _in_context "Expected a $opposite_of{$subname} block ",
333             "after the $subname block ",
334             "but found instead: $vals\n";
335             }
336              
337             # Handle void context calls...
338 28 50 66     58 if (!defined wantarray && $impl->{NVALUE}) {
339             # Fake out caller() and Carp...
340 1         2 local $Contextual::Return::uplevel = 1;
341 31     31   132 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         31  
  31         3331  
  1         4  
342              
343             # Call and clear handler...
344 1         3 local $Contextual::Return::__RETOBJ__ = $impl;
345 1         2 $impl->{NVALUE}( @{$impl->{args}} );
  1         6  
346 1         436 delete $impl->{NVALUE};
347             }
348 28         87 $_[0];
349             }
350 93         338 }
351             }
352              
353             for my $modifier_name (qw< STRICT FIXED ACTIVE >) {
354 31     31   119 no strict 'refs';
  31         41  
  31         2929  
355             *{$modifier_name} = sub ($) {
356 21     21   22 my ($crv) = @_;
357 21   50     49 my $attrs = $attrs_of{refaddr $crv or q{}};
358              
359             # Track context...
360 21         17 my $wantarray = wantarray;
361 31     31   13306 use Want;
  31         43906  
  31         2732  
362 21   66     60 $attrs->{want_pure_bool} ||= Want::want('BOOL');
363              
364             # Remember the modification...
365 21         721 $attrs->{$modifier_name} = 1;
366              
367             # Prepare for exception handling...
368 21         22 my $recover = $attrs->{RECOVER};
369 21         15 local $Contextual::Return::uplevel = 2;
370 31     31   158 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         38  
  31         18364  
  21         24  
371              
372             # Handle list context directly, if possible...
373 21 100       30 if ($wantarray) {
374 2         4 local $Contextual::Return::__RESULT__;
375             # List or ancestral handlers...
376             handler:
377 2         8 for my $context (qw(LIST VALUE NONVOID DEFAULT)) {
378             my $handler = $attrs->{$context}
379             or $attrs->{STRICT} and last handler
380 2 0 0     9 or next handler;
      33        
381              
382 2         3 my @rv = eval { $handler->(@{$attrs->{args}}) };
  2         3  
  2         7  
383 2 50       15 if ($recover) {
    50          
384 0 0       0 if (!$Contextual::Return::__RESULT__) {
385 0         0 $Contextual::Return::__RESULT__ = [@rv];
386             }
387 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
388             }
389             elsif ($@) {
390 0         0 die $@;
391             }
392              
393 2 50       17 return @rv if !$Contextual::Return::__RESULT__;
394 0         0 return @{$Contextual::Return::__RESULT__};
  0         0  
395             }
396             # Convert to list from arrayref handler...
397 0 0 0     0 if (!$attrs->{STRICT} and my $handler = $attrs->{ARRAYREF}) {
398 0         0 my $array_ref = eval { $handler->(@{$attrs->{args}}) };
  0         0  
  0         0  
399              
400 0 0       0 if ($recover) {
    0          
401 0 0       0 if (!$Contextual::Return::__RESULT__) {
402 0         0 $Contextual::Return::__RESULT__ = [$array_ref];
403             }
404 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
405             }
406             elsif ($@) {
407 0         0 die $@;
408             }
409              
410             # Array ref may be returned directly, or via RESULT{}...
411 0 0       0 $array_ref = $Contextual::Return::__RESULT__->[0]
412             if $Contextual::Return::__RESULT__;
413              
414 0 0 0     0 return @{$array_ref} if (ref $array_ref||q{}) eq 'ARRAY';
  0         0  
415             }
416             # Return scalar object as one-elem list, if possible...
417             handler:
418 0         0 for my $context (qw(BOOL STR NUM VALUE SCALAR LAZY)) {
419 0 0       0 last handler if $attrs->{STRICT};
420 0 0       0 return $crv if exists $attrs->{$context};
421             }
422 0         0 $@ = _in_context "Can't call $attrs->{sub} in a list context";
423 0 0       0 if ($recover) {
424 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
425             }
426             else {
427 0         0 die $@;
428             }
429             }
430              
431             # Handle void context directly...
432 19 100       29 if (!defined $wantarray) {
433             handler:
434 1         2 for my $context (qw< VOID DEFAULT >) {
435             my $handler = $attrs->{$context}
436             or $attrs->{STRICT} and last handler
437 1 0 50     7 or next handler;
      33        
438              
439 0         0 eval { $attrs->{$context}->(@{$attrs->{args}}) };
  0         0  
  0         0  
440 0 0       0 if ($recover) {
    0          
441 0         0 $recover->(@{$attrs->{args}});
  0         0  
442             }
443             elsif ($@) {
444 0         0 die $@;
445             }
446 0         0 last handler;
447             }
448 1 50       2 if ($attrs->{STRICT}) {
449 1         5 $@ = _in_context "Can't call $attrs->{sub} in a void context";
450 1 50       2 if ($recover) {
451 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
452             }
453             else {
454 1         10 die $@;
455             }
456             }
457 0         0 return;
458             }
459              
460             # Otherwise, let someone else handle it...
461 18         50 return $crv;
462             }
463             }
464              
465             sub LIST (;&$) {
466 144     144 1 197 my ($block, $crv) = @_;
467              
468             # Handle simple context tests...
469 144 100       241 return !!(CORE::caller 1)[5] if !@_;
470              
471             # Ensure we have an object...
472 142         117 my $attrs;
473 142 100       285 if (!refaddr $crv) {
474 12         8 my $args = do{ package DB; ()=CORE::caller(1); my $args = \@DB::args; ()=CORE::caller(1); $args };
  12         91  
  12         24  
  12         31  
  12         16  
475 12         29 my $subname = (CORE::caller(1))[3];
476 12 50       29 if (!defined $subname) {
477 0         0 $subname = 'bare LIST {...}';
478             }
479 12         20 $crv = bless \my $scalar, 'Contextual::Return::Value';
480 12         51 $attrs = $attrs_of{refaddr $crv} = { args => $args, sub => $subname };
481             }
482             else {
483 130         240 $attrs = $attrs_of{refaddr $crv};
484             }
485 142         140 local $Contextual::Return::__RETOBJ__ = $crv;
486              
487             # Handle repetitions...
488             die _in_context "Can't install two LIST handlers"
489 142 100       260 if exists $attrs->{LIST};
490              
491             # Identify contexts...
492 141         144 my $wantarray = wantarray;
493 31     31   152 use Want;
  31         37  
  31         1920  
494 141   33     411 $attrs->{want_pure_bool} ||= Want::want('BOOL');
495              
496             # Prepare for exception handling...
497 141         4542 my $recover = $attrs->{RECOVER};
498 141         141 local $Contextual::Return::uplevel = 2;
499 31     31   121 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         38  
  31         12980  
  141         181  
500              
501             # Handle list context directly...
502 141 100       225 if ($wantarray) {
503 2         2 local $Contextual::Return::__RESULT__;
504              
505 2         3 my @rv = eval { $block->(@{$attrs->{args}}) };
  2         2  
  2         6  
506 2 50       15 if ($recover) {
    50          
507 0 0       0 if (!$Contextual::Return::__RESULT__) {
508 0         0 $Contextual::Return::__RESULT__ = [@rv];
509             }
510 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
511             }
512             elsif ($@) {
513 0         0 die $@;
514             }
515              
516 2 50       13 return @rv if !$Contextual::Return::__RESULT__;
517 0         0 return @{$Contextual::Return::__RESULT__};
  0         0  
518             }
519              
520             # Handle void context directly...
521 139 50       224 if (!defined $wantarray) {
522             handler:
523 0         0 for my $context (qw< VOID DEFAULT >) {
524             my $handler = $attrs->{$context}
525             or $attrs->{STRICT} and last handler
526 0 0 0     0 or next handler;
      0        
527              
528 0         0 eval { $attrs->{$context}->(@{$attrs->{args}}) };
  0         0  
  0         0  
529 0 0       0 if ($recover) {
    0          
530 0         0 $recover->(@{$attrs->{args}});
  0         0  
531             }
532             elsif ($@) {
533 0         0 die $@;
534             }
535 0         0 last handler;
536             }
537 0 0       0 if ($attrs->{STRICT}) {
538 0         0 $@ = _in_context "Can't call $attrs->{sub} in a void context";
539 0 0       0 if ($recover) {
540 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
541             }
542             else {
543 0         0 die $@;
544             }
545             }
546 0         0 return;
547             }
548              
549             # Otherwise, cache handler...
550 139         181 $attrs->{LIST} = $block;
551 139         285 return $crv;
552             }
553              
554              
555             sub VOID (;&$) {
556 62     62 1 3192 my ($block, $crv) = @_;
557              
558             # Handle simple context tests...
559 62 100       142 return !defined( (CORE::caller 1)[5] ) if !@_;
560              
561             # Ensure we have an object...
562 56         50 my $attrs;
563 56 100       135 if (!refaddr $crv) {
564 6         7 my $args = do{ package DB; ()=CORE::caller(1); my $args = \@DB::args; ()=CORE::caller(1); $args };
  6         39  
  6         14  
  6         19  
  6         11  
565 6         21 my $subname = (CORE::caller(1))[3];
566 6 50       14 if (!defined $subname) {
567 0         0 $subname = 'bare VOID {...}';
568             }
569 6         26 $crv = bless \my $scalar, 'Contextual::Return::Value';
570 6         37 $attrs = $attrs_of{refaddr $crv} = { args => $args, sub => $subname };
571             }
572             else {
573 50         110 $attrs = $attrs_of{refaddr $crv};
574             }
575 56         55 local $Contextual::Return::__RETOBJ__ = $crv;
576              
577             # Handle repetitions...
578             die _in_context "Can't install two VOID handlers"
579 56 50       122 if exists $attrs->{VOID};
580              
581             # Identify contexts...
582 56         63 my $wantarray = wantarray;
583 31     31   142 use Want;
  31         40  
  31         1937  
584 56   66     186 $attrs->{want_pure_bool} ||= Want::want('BOOL');
585              
586             # Prepare for exception handling...
587 56         2852 my $recover = $attrs->{RECOVER};
588 56         61 local $Contextual::Return::uplevel = 2;
589 31     31   134 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         45  
  31         11528  
  56         104  
590              
591             # Handle list context directly, if possible...
592 56 100       107 if ($wantarray) {
593 6         5 local $Contextual::Return::__RESULT__;
594             # List or ancestral handlers...
595             handler:
596 6         14 for my $context (qw(LIST VALUE NONVOID DEFAULT)) {
597             my $handler = $attrs->{$context}
598             or $attrs->{STRICT} and last handler
599 6 0 0     21 or next handler;
      33        
600              
601 6         8 my @rv = eval { $handler->(@{$attrs->{args}}) };
  6         8  
  6         19  
602 6 50       51 if ($recover) {
    50          
603 0 0       0 if (!$Contextual::Return::__RESULT__) {
604 0         0 $Contextual::Return::__RESULT__ = [@rv];
605             }
606 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
607             }
608             elsif ($@) {
609 0         0 die $@;
610             }
611              
612 6 100       24 return @rv if !$Contextual::Return::__RESULT__;
613 3         4 return @{$Contextual::Return::__RESULT__};
  3         15  
614             }
615             # Convert to list from arrayref handler...
616 0 0 0     0 if (!$attrs->{STRICT} and my $handler = $attrs->{ARRAYREF}) {
617 0         0 my $array_ref = eval { $handler->(@{$attrs->{args}}) };
  0         0  
  0         0  
618              
619 0 0       0 if ($recover) {
    0          
620 0 0       0 if (!$Contextual::Return::__RESULT__) {
621 0         0 $Contextual::Return::__RESULT__ = [$array_ref];
622             }
623 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
624             }
625             elsif ($@) {
626 0         0 die $@;
627             }
628              
629             # Array ref may be returned directly, or via RESULT{}...
630 0 0       0 $array_ref = $Contextual::Return::__RESULT__->[0]
631             if $Contextual::Return::__RESULT__;
632              
633 0 0 0     0 return @{$array_ref} if (ref $array_ref||q{}) eq 'ARRAY';
  0         0  
634             }
635             # Return scalar object as one-elem list, if possible...
636             handler:
637 0         0 for my $context (qw(BOOL STR NUM VALUE SCALAR LAZY)) {
638 0 0       0 last handler if $attrs->{STRICT};
639 0 0       0 return $crv if exists $attrs->{$context};
640             }
641 0         0 $@ = _in_context "Can't call $attrs->{sub} in a list context";
642 0 0       0 if ($recover) {
643 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
644             }
645             else {
646 0         0 die $@;
647             }
648             }
649              
650             # Handle void context directly...
651 50 100       98 if (!defined $wantarray) {
652 2         5 eval { $block->(@{$attrs->{args}}) };
  2         4  
  2         8  
653              
654 2 50       14 if ($recover) {
    50          
655 0         0 $recover->(@{$attrs->{args}});
  0         0  
656             }
657             elsif ($@) {
658 0         0 die $@;
659             }
660              
661 2         6 return;
662             }
663              
664             # Otherwise, cache handler...
665 48         78 $attrs->{VOID} = $block;
666 48         525 return $crv;
667             }
668              
669             for my $context (qw( SCALAR NONVOID )) {
670 31     31   136 no strict qw( refs );
  31         39  
  31         5858  
671             *{$context} = sub (;&$) {
672 138     138   262 my ($block, $crv) = @_;
673              
674             # Handle simple context tests...
675 138 100       271 if (!@_) {
676 3         7 my $callers_context = (CORE::caller 1)[5];
677 3   33     45 return defined $callers_context
678             && ($context eq 'NONVOID' || !$callers_context);
679             }
680              
681             # Ensure we have an object...
682 135         113 my $attrs;
683 135 100       316 if (!refaddr $crv) {
684 11         10 my $args = do{ package DB; ()=CORE::caller(1); my $args = \@DB::args; ()=CORE::caller(1); $args };
  11         70  
  11         21  
  11         39  
  11         22  
685 11         34 my $subname = (CORE::caller(1))[3];
686 11 50       37 if (!defined $subname) {
687 0         0 $subname = "bare $context {...}";
688             }
689 11         30 $crv = bless \my $scalar, 'Contextual::Return::Value';
690 11         68 $attrs = $attrs_of{refaddr $crv}
691             = { args => $args, sub => $subname };
692             }
693             else {
694 124         209 $attrs = $attrs_of{refaddr $crv};
695             }
696 135         131 local $Contextual::Return::__RETOBJ__ = $crv;
697              
698             # Make sure this block is a possibility too...
699             die _in_context "Can't install two $context handlers"
700 135 50       265 if exists $attrs->{$context};
701 135         166 $attrs->{$context} = $block;
702              
703             # Identify contexts...
704 135         132 my $wantarray = wantarray;
705 31     31   138 use Want ();
  31         38  
  31         1215  
706 135   33     447 $attrs->{want_pure_bool} ||= Want::want('BOOL');
707              
708             # Prepare for exception handling...
709 135         4946 my $recover = $attrs->{RECOVER};
710 135         137 local $Contextual::Return::uplevel = 2;
711 31     31   110 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         40  
  31         13885  
  135         191  
712              
713             # Handle list context directly, if possible...
714 135 100       227 if ($wantarray) {
715 2         3 local $Contextual::Return::__RESULT__;
716              
717             # List or ancestral handlers...
718             handler:
719 2         4 for my $context (qw(LIST VALUE NONVOID DEFAULT)) {
720             my $handler = $attrs->{$context}
721             or $attrs->{STRICT} and last handler
722 7 50 50     27 or next handler;
      66        
723              
724 1         2 my @rv = eval { $handler->(@{$attrs->{args}}) };
  1         1  
  1         3  
725 1 50       7 if ($recover) {
    50          
726 0 0       0 if (!$Contextual::Return::__RESULT__) {
727 0         0 $Contextual::Return::__RESULT__ = [@rv];
728             }
729 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
730             }
731             elsif ($@) {
732 0         0 die $@;
733             }
734              
735 1 50       13 return @rv if !$Contextual::Return::__RESULT__;
736 0         0 return @{$Contextual::Return::__RESULT__};
  0         0  
737             }
738             # Convert to list from arrayref handler...
739 1 50 33     9 if (!$attrs->{STRICT} and my $handler = $attrs->{ARRAYREF}) {
740              
741 0         0 my $array_ref = eval { $handler->(@{$attrs->{args}}) };
  0         0  
  0         0  
742 0 0       0 if ($recover) {
    0          
743 0 0       0 if (!$Contextual::Return::__RESULT__) {
744 0         0 $Contextual::Return::__RESULT__ = [$array_ref];
745             }
746 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
747             }
748             elsif ($@) {
749 0         0 die $@;
750             }
751              
752             # Array ref may be returned directly, or via RESULT{}...
753 0 0       0 $array_ref = $Contextual::Return::__RESULT__->[0]
754             if $Contextual::Return::__RESULT__;
755              
756 0 0 0     0 return @{$array_ref} if (ref $array_ref||q{}) eq 'ARRAY';
  0         0  
757             }
758             # Return scalar object as one-elem list, if possible...
759             handler:
760 1         3 for my $context (qw(BOOL STR NUM VALUE SCALAR LAZY)) {
761 5 50       7 last if $attrs->{STRICT};
762 5 100       38 return $crv if exists $attrs->{$context};
763             }
764 0         0 die _in_context "Can't call $attrs->{sub} in a list context";
765             }
766              
767             # Handle void context directly...
768 133 100       228 if (!defined $wantarray) {
769             handler:
770 1         3 for my $context (qw< VOID DEFAULT >) {
771             my $handler = $attrs->{$context}
772             or $attrs->{STRICT} and last handler
773 1 0 0     3 or next handler;
      33        
774              
775 1         2 eval { $handler->(@{$attrs->{args}}) };
  1         2  
  1         2  
776 1 50       13 if ($recover) {
    50          
777 0         0 $recover->(@{$attrs->{args}});
  0         0  
778             }
779             elsif ($@) {
780 1         5 die $@;
781             }
782              
783 0         0 last handler;
784             }
785 0 0       0 if ($attrs->{STRICT}) {
786 0         0 $@ = _in_context "Can't call $attrs->{sub} in a void context";
787 0 0       0 if ($recover) {
788 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
789             }
790             else {
791 0         0 die $@;
792             }
793             }
794 0         0 return;
795             }
796              
797             # Otherwise, defer evaluation by returning an object...
798 132         410 return $crv;
799             }
800             }
801              
802             handler:
803             for my $context_name (@CONTEXTS, qw< RECOVER _internal_LIST CLEANUP >) {
804             next handler if $context_name eq 'LIST' # These
805             || $context_name eq 'VOID' # four
806             || $context_name eq 'SCALAR' # handled
807             || $context_name eq 'NONVOID'; # separately
808              
809 31     31   137 no strict qw( refs );
  31         39  
  31         5688  
810             *{$context_name} = sub (&;$) {
811 1125     1125   6096 my ($block, $crv) = @_;
812              
813             # Ensure we have an object...
814 1125         914 my $attrs;
815 1125 100       2118 if (!refaddr $crv) {
816 219         201 my $args = do{ package DB; ()=CORE::caller(1); my $args = \@DB::args; ()=CORE::caller(1); $args };
  219         1018  
  219         371  
  219         486  
  219         324  
817 219         487 my $subname = (CORE::caller(1))[3];
818 219 50       469 if (!defined $subname) {
819 0         0 $subname = "bare $context_name {...}";
820             }
821 219         431 $crv = bless \my $scalar, 'Contextual::Return::Value';
822 219         928 $attrs = $attrs_of{refaddr $crv}
823             = { args => $args, sub => $subname };
824             }
825             else {
826 906         1370 $attrs = $attrs_of{refaddr $crv};
827             }
828 1125         957 local $Contextual::Return::__RETOBJ__ = $crv;
829              
830             # Make sure this block is a possibility too...
831 1125 50       1717 if ($context_name ne '_internal_LIST') {
832             die _in_context "Can't install two $context_name handlers"
833 1125 50       1691 if exists $attrs->{$context_name};
834 1125         1323 $attrs->{$context_name} = $block;
835             }
836              
837             # Identify contexts...
838 1125         969 my $wantarray = wantarray;
839 31     31   134 use Want ();
  31         42  
  31         1189  
840 1125   66     2942 $attrs->{want_pure_bool} ||= Want::want('BOOL');
841              
842             # Prepare for exception handling...
843 1125         40997 my $recover = $attrs->{RECOVER};
844 1125         938 local $Contextual::Return::uplevel = 2;
845 31     31   667 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         46  
  31         19014  
  1125         1448  
846              
847             # Handle list context directly, if possible...
848 1125 100       1542 if ($wantarray) {
849 15 50       47 local $Contextual::Return::__RESULT__
850             = $context_name eq 'RECOVER' ? $Contextual::Return::__RESULT__
851             : undef
852             ;
853              
854             # List or ancestral handlers...
855             handler:
856 15         36 for my $context (qw(LIST VALUE NONVOID DEFAULT)) {
857             my $handler = $attrs->{$context}
858             or $attrs->{STRICT} and last handler
859 36 50 50     126 or next handler;
      66        
860              
861 12         18 my @rv = eval { $handler->(@{$attrs->{args}}) };
  12         14  
  12         37  
862 12 100       77 if ($recover) {
    100          
863 2 50       5 if (!$Contextual::Return::__RESULT__) {
864 2         4 $Contextual::Return::__RESULT__ = [@rv];
865             }
866 2         2 () = $recover->(@{$attrs->{args}});
  2         4  
867             }
868             elsif ($@) {
869 3         12 die $@;
870             }
871              
872 9 100       666 return @rv if !$Contextual::Return::__RESULT__;
873 3         4 return @{$Contextual::Return::__RESULT__};
  3         24  
874             }
875             # Convert to list from arrayref handler...
876 3 100 66     21 if (!$attrs->{STRICT} and my $handler = $attrs->{ARRAYREF}) {
877 1         5 local $Contextual::Return::uplevel = 2;
878              
879             # Array ref may be returned directly, or via RESULT{}...
880 1         3 my $array_ref = eval { $handler->(@{$attrs->{args}}) };
  1         2  
  1         5  
881 1 50       940 if ($recover) {
    50          
882 0 0       0 if (!$Contextual::Return::__RESULT__) {
883 0         0 $Contextual::Return::__RESULT__ = [$array_ref];
884             }
885 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
886             }
887             elsif ($@) {
888 0         0 die $@;
889             }
890              
891 1 50       5 $array_ref = $Contextual::Return::__RESULT__->[0]
892             if $Contextual::Return::__RESULT__;
893              
894 1 50 50     9 return @{$array_ref} if (ref $array_ref||q{}) eq 'ARRAY';
  1         8  
895             }
896             # Return scalar object as one-elem list, if possible...
897             handler:
898 2         4 for my $context (qw(BOOL STR NUM VALUE SCALAR LAZY)) {
899 5 50       6 last if $attrs->{STRICT};
900 5 100       20 return $crv if exists $attrs->{$context};
901             }
902 0         0 $@ = _in_context "Can't call $attrs->{sub} in a list context";
903 0 0       0 if ($recover) {
904 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
905             }
906             else {
907 0         0 die $@;
908             }
909             }
910              
911             # Handle void context directly...
912 1110 100       1492 if (!defined $wantarray) {
913             handler:
914 6         17 for my $context (qw(VOID DEFAULT)) {
915 9 100       25 if (!$attrs->{$context}) {
916 3 50       8 last handler if $attrs->{STRICT};
917 3         5 next handler;
918             }
919              
920 6         10 eval { $attrs->{$context}->(@{$attrs->{args}}) };
  6         11  
  6         28  
921              
922 6 100       34 if ($recover) {
    100          
923 1         1 $recover->(@{$attrs->{args}});
  1         3  
924             }
925             elsif ($@) {
926 4         21 die $@;
927             }
928              
929 2         263 last handler;
930             }
931 2 50       6 if ($attrs->{STRICT}) {
932 0         0 $@ = _in_context "Can't call $attrs->{sub} in a void context";
933 0 0       0 if ($recover) {
934 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
935             }
936             else {
937 0         0 die $@;
938             }
939             }
940 2         4 return;
941             }
942              
943             # Otherwise, defer evaluation by returning an object...
944 1104         2774 return $crv;
945             }
946             }
947              
948             # Alias LAZY to SCALAR...
949             *LAZY = *SCALAR;
950              
951              
952             # Set $Data::Dumper::Freezer to 'Contextual::Return::FREEZE' to be able to
953             # dump contextual return values...
954              
955             my %operator_impl;
956              
957             my $no_handler_message = qr{
958             ^ Can't [ ] call [ ] .*? [ ] in [ ] [\w]+ [ ] context
959             | ^ [\w:]+ [ ] can't [ ] return [ ] a [ ] \w+ [ ] reference
960             }xms;
961              
962             sub _flag_self_ref_in {
963 0     0   0 my ($data_ref, $obj_ref) = @_;
964 0         0 my $type = ref $data_ref;
965 0 0       0 return if !$type;
966 0 0       0 for my $ref ( $type eq 'SCALAR' ? ${$data_ref} : $type eq 'ARRAY' ? @{$data_ref} : ()) {
  0 0       0  
  0         0  
967 31     31   152 no warnings 'numeric', 'uninitialized';
  31         38  
  31         5808  
968 0 0       0 if (refaddr($ref) == refaddr($obj_ref)) {
969 0         0 $ref = '<<>>';
970             }
971             }
972             }
973              
974             sub FREEZE {
975 0     0 1 0 my ($self) = @_;
976 0         0 my $attrs_ref = $attrs_of{refaddr $self};
977 0         0 my $args_ref = $attrs_ref->{args};
978              
979 0         0 my @no_handler;
980              
981             # Call appropriate operator handler, defusing and recording exceptions...
982             my $overloaded = sub {
983 0     0   0 my ($context, $op) = @_;
984              
985             # Try the operator...
986 0         0 my $retval = eval { $operator_impl{$op}->($self,@{$args_ref}) };
  0         0  
  0         0  
987              
988             # Detect and report internal exceptions...
989 0 0       0 if (my $exception = $@) {
990 0 0       0 if ($exception =~ $no_handler_message) {
991 0         0 push @no_handler, $context;
992 0         0 return ();
993             }
994 0         0 chomp $exception;
995 0         0 return { $context => "<<>>" };
996             }
997              
998             # Detect self-referential overloadings (to avoid infinite recursion)...
999             {
1000 31     31   135 no warnings 'numeric', 'uninitialized';
  31         36  
  31         24054  
  0         0  
1001 0 0 0     0 if (ref $retval eq 'REF' && eval{ ${$retval} == ${$self} }) {
  0         0  
  0         0  
  0         0  
1002 0         0 return { $context => "<<>>" };
1003             }
1004             }
1005              
1006             # Normal return of contextual value labelled by context...
1007 0         0 return { $context => $retval };
1008 0         0 };
1009              
1010 0         0 my @values;
1011              
1012             # Where did this value originate?
1013 0         0 push @values, { ISA => 'Contextual::Return::Value' };
1014 0         0 push @values, { FROM => $attrs_ref->{sub} };
1015              
1016             # Does it return a value in void context?
1017 0 0 0     0 if (exists $attrs_ref->{VOID} || exists $attrs_ref->{DEFAULT}) {
1018 0         0 push @values, { VOID => undef };
1019             }
1020             else {
1021 0         0 push @no_handler, 'VOID';
1022             }
1023              
1024             # Generate list context value by "pretend" LIST handler...
1025 0   0 0   0 push @values, { LIST => eval{ [ _internal_LIST(sub{}, $self) ] } // do{ chomp $@; "<<>>"} };
  0         0  
  0         0  
  0         0  
1026 0         0 _flag_self_ref_in($values[-1]{LIST}, $self);
1027              
1028             # Generate scalar context values by calling appropriate handler...
1029 0         0 push @values, $overloaded->( STR => q{""} );
1030 0         0 push @values, $overloaded->( NUM => '0+' );
1031 0         0 push @values, $overloaded->( BOOL => 'bool' );
1032 0         0 push @values, $overloaded->( SCALARREF => '${}' );
1033 0         0 _flag_self_ref_in($values[-1]{SCALARREF}, $self);
1034 0         0 push @values, $overloaded->( ARRAYREF => '@{}' );
1035 0         0 _flag_self_ref_in($values[-1]{ARRAYREF}, $self);
1036 0         0 push @values, $overloaded->( CODEREF => '&{}' );
1037 0         0 push @values, $overloaded->( HASHREF => '%{}' );
1038 0         0 push @values, $overloaded->( GLOBREF => '*{}' );
1039              
1040             # Are there handlers for various "generic" super-contexts...
1041 0         0 my @fallbacks = grep { $attrs_ref->{$_} }
  0         0  
1042             qw< DEFAULT NONVOID SCALAR VALUE REF RECOVER >;
1043              
1044 0         0 push @values, { NO_HANDLER => \@no_handler };
1045 0         0 push @values, { FALLBACKS => \@fallbacks };
1046              
1047             # Temporarily replace object being dumped, by values found...
1048 0         0 $_[0] = \@values;
1049             }
1050              
1051             # Call this method on a contextual return value object to debug it...
1052              
1053             sub DUMP {
1054 0 0   0 1 0 if (eval{ require Data::Dumper; 1; }) {
  0         0  
  0         0  
1055 0         0 my ($crv) = @_;
1056 0 0       0 if (eval{ ref($crv)->isa('Contextual::Return::Value')}) {
  0         0  
1057 0         0 Contextual::Return::FREEZE($crv);
1058             }
1059 0         0 local $Data::Dumper::Terse = 1;
1060 0         0 local $Data::Dumper::Indent = 1;
1061 0         0 my $dump = Data::Dumper::Dumper($crv);
1062 0         0 $dump =~ s<,\n \{><,ZZZZ{>msg;
1063 0         0 $dump =~ s<\n\s+>< >msg;
1064 0         0 $dump =~ s<,ZZZZ\{><\n {>msg;
1065 0         0 return $dump;
1066             }
1067             else {
1068 0         0 Carp::carp("Can't DUMP contextual return value (no Data::Dumper!)");
1069 0         0 return;
1070             }
1071             }
1072              
1073              
1074             package Contextual::Return::Value;
1075 31     31   716 BEGIN { *_in_context = *Contextual::Return::_in_context; }
1076 31     31   149 use Scalar::Util qw( refaddr );
  31         30  
  31         2400  
1077              
1078             BEGIN {
1079             %operator_impl = (
1080             q{""} => sub {
1081 39     39   774 my ($self) = @_;
1082 39         177 local $Contextual::Return::__RETOBJ__ = $self;
1083 31     31   124 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         35  
  31         9130  
  39         71  
1084              
1085 39         123 my $attrs = $attrs_of{refaddr $self};
1086             handler:
1087 39         92 for my $context (qw(STR SCALAR LAZY VALUE NONVOID DEFAULT NUM)) {
1088             my $handler = $attrs->{$context}
1089             or $attrs->{STRICT} and last handler
1090 95 50 50     315 or next handler;
      66        
1091              
1092 39         49 local $Contextual::Return::__RESULT__;
1093 39         62 local $Contextual::Return::uplevel = 2;
1094 39         65 my $rv = eval { $handler->(@{$attrs->{args}}) };
  39         51  
  39         115  
1095              
1096 39 100       1102 if (my $recover = $attrs->{RECOVER}) {
    100          
1097 4 50       11 if (!$Contextual::Return::__RESULT__) {
1098 4         9 $Contextual::Return::__RESULT__ = [$rv];
1099             }
1100 4         6 scalar $recover->(@{$attrs->{args}});
  4         12  
1101             }
1102             elsif ($@) {
1103 3         12 die $@;
1104             }
1105              
1106 36 100       616 if ($Contextual::Return::__RESULT__) {
1107 8         14 $rv = $Contextual::Return::__RESULT__->[0];
1108             }
1109              
1110 36 100       139 if ( $attrs->{FIXED} ) {
    50          
1111 2         3 $_[0] = $rv;
1112             }
1113             elsif ( !$attrs->{ACTIVE} ) {
1114 34     0   131 $attrs->{$context} = sub { $rv };
  0         0  
1115             }
1116 36         234 return $rv;
1117             }
1118 0         0 $@ = _in_context "Can't use return value of $attrs->{sub} as a string";
1119 0 0       0 if (my $recover = $attrs->{RECOVER}) {
1120 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
1121             }
1122             else {
1123 0         0 die $@;
1124             }
1125             },
1126              
1127             q{0+} => sub {
1128 30     30   1088 my ($self) = @_;
1129 30         59 local $Contextual::Return::__RETOBJ__ = $self;
1130 31     31   520 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         49  
  31         8688  
  30         54  
1131 30         112 my $attrs = $attrs_of{refaddr $self};
1132             handler:
1133 30         87 for my $context (qw(NUM SCALAR LAZY VALUE NONVOID DEFAULT STR)) {
1134             my $handler = $attrs->{$context}
1135             or $attrs->{STRICT} and last handler
1136 50 50 50     188 or next handler;
      66        
1137              
1138 30         42 local $Contextual::Return::__RESULT__;
1139 30         51 local $Contextual::Return::uplevel = 2;
1140 30         49 my $rv = eval { $handler->(@{$attrs->{args}}) };
  30         40  
  30         92  
1141              
1142 30 100       193 if (my $recover = $attrs->{RECOVER}) {
    100          
1143 5 50       18 if (!$Contextual::Return::__RESULT__) {
1144 5         10 $Contextual::Return::__RESULT__ = [$rv];
1145             }
1146 5         7 scalar $recover->(@{$attrs->{args}});
  5         14  
1147             }
1148             elsif ($@) {
1149 3         14 die $@;
1150             }
1151              
1152 27 100       617 if ($Contextual::Return::__RESULT__) {
1153 9         15 $rv = $Contextual::Return::__RESULT__->[0];
1154             }
1155              
1156 27 100       136 if ( $attrs->{FIXED} ) {
    50          
1157 1         2 $_[0] = $rv;
1158             }
1159             elsif ( !$attrs->{ACTIVE} ) {
1160 26     1   115 $attrs->{$context} = sub { $rv };
  1         1  
1161             }
1162 27         158 return $rv;
1163             }
1164 0         0 $@ = _in_context "Can't use return value of $attrs->{sub} as a number";
1165 0 0       0 if (my $recover = $attrs->{RECOVER}) {
1166 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
1167             }
1168             else {
1169 0         0 die $@;
1170             }
1171             },
1172              
1173             q{bool} => sub {
1174 34     34   1571 my ($self) = @_;
1175 34         52 local $Contextual::Return::__RETOBJ__ = $self;
1176 31     31   133 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         277  
  31         12179  
  34         65  
1177 34         113 my $attrs = $attrs_of{refaddr $self};
1178              
1179             # Handle Calls in Pure Boolean context...
1180 34 100       134 my @PUREBOOL = $attrs->{want_pure_bool} ? ('PUREBOOL') : ();
1181 34         59 $attrs->{want_pure_bool} = 0;
1182              
1183             handler:
1184 34         75 for my $context (@PUREBOOL, qw(BOOL STR NUM SCALAR LAZY VALUE NONVOID DEFAULT)) {
1185             my $handler = $attrs->{$context}
1186             or $context eq 'BOOL' and $attrs->{STRICT} and last handler
1187 57 50 66     232 or next handler;
      50        
      66        
1188              
1189 35         45 local $Contextual::Return::__RESULT__;
1190 35         49 local $Contextual::Return::uplevel = 2;
1191 35         73 my $outer_sig_warn = $SIG{__WARN__};
1192             local $SIG{__WARN__}
1193 1 50   1   7 = sub{ return if $_[0] =~ /^Exiting \S+ via next/;
1194 1 50       4 goto &{$outer_sig_warn} if $outer_sig_warn;
  1         5  
1195 0         0 warn @_;
1196 35         236 };
1197 35         65 my $rv = eval { $handler->(@{$attrs->{args}}) };
  35         50  
  35         111  
1198              
1199 34 100       1557 if (my $recover = $attrs->{RECOVER}) {
    50          
1200 4 50       10 if (!$Contextual::Return::__RESULT__) {
1201 4         8 $Contextual::Return::__RESULT__ = [$rv];
1202             }
1203 4         5 scalar $recover->(@{$attrs->{args}});
  4         10  
1204             }
1205             elsif ($@) {
1206 0         0 die $@;
1207             }
1208              
1209 34 100       935 if ($Contextual::Return::__RESULT__) {
1210 8         16 $rv = $Contextual::Return::__RESULT__->[0];
1211             }
1212              
1213 34 100       128 if ( $attrs->{FIXED} ) {
    50          
1214 1         2 $_[0] = $rv;
1215             }
1216             elsif ( !$attrs->{ACTIVE} ) {
1217 33     3   113 $attrs->{$context} = sub { $rv };
  3         8  
1218             }
1219 34         358 return $rv;
1220             }
1221 0         0 $@ = _in_context "Can't use return value of $attrs->{sub} as a boolean";
1222 0 0       0 if (my $recover = $attrs->{RECOVER}) {
1223 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
1224             }
1225             else {
1226 0         0 die $@;
1227             }
1228             },
1229             '${}' => sub {
1230 24     24   733 my ($self) = @_;
1231 24         37 local $Contextual::Return::__RETOBJ__ = $self;
1232 31     31   144 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         41  
  31         10072  
  24         35  
1233 24         70 my $attrs = $attrs_of{refaddr $self};
1234             handler:
1235 24         45 for my $context (qw(SCALARREF REF NONVOID DEFAULT)) {
1236             my $handler = $attrs->{$context}
1237             or $attrs->{STRICT} and last handler
1238 48 50 100     179 or next handler;
      66        
1239              
1240 15         21 local $Contextual::Return::__RESULT__;
1241 15         22 local $Contextual::Return::uplevel = 2;
1242 15         28 my $rv = eval { $handler->(@{$attrs->{args}}) };
  15         17  
  15         46  
1243              
1244 15 100       132 if (my $recover = $attrs->{RECOVER}) {
    50          
1245 1 50       3 if (!$Contextual::Return::__RESULT__) {
1246 1         1 $Contextual::Return::__RESULT__ = [$rv];
1247             }
1248 1         2 scalar $recover->(@{$attrs->{args}});
  1         4  
1249             }
1250             elsif ($@) {
1251 0         0 die $@;
1252             }
1253              
1254 15 100       324 if ($Contextual::Return::__RESULT__) {
1255 5         10 $rv = $Contextual::Return::__RESULT__->[0];
1256             }
1257              
1258             # Catch bad behaviour...
1259 15 50 33     64 die _in_context "$context block did not return ",
1260             "a suitable reference to the scalar dereference"
1261             if ref($rv) ne 'SCALAR' && ref($rv) ne 'OBJ';
1262              
1263 15 100       57 if ( $attrs->{FIXED} ) {
    50          
1264 1         2 $_[0] = $rv;
1265             }
1266             elsif ( !$attrs->{ACTIVE} ) {
1267 14     0   60 $attrs->{$context} = sub { $rv };
  0         0  
1268             }
1269 15         111 return $rv;
1270             }
1271              
1272 9 100       19 if ($attrs->{STRICT}) {
1273 1         5 $@ = _in_context "Call to $attrs->{sub} didn't return a scalar reference, as required ";
1274 1 50       5 if (my $recover = $attrs->{RECOVER}) {
1275 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
1276             }
1277             else {
1278 1         7 die $@;
1279             }
1280             }
1281              
1282 8 100       21 if ( $attrs->{FIXED} ) {
1283 1         1 $_[0] = \$self;
1284             }
1285 8         30 return \$self;
1286             },
1287             '@{}' => sub {
1288 22     22   758 my ($self) = @_;
1289 22         34 local $Contextual::Return::__RETOBJ__ = $self;
1290 31     31   140 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         41  
  31         14137  
  22         47  
1291 22         76 my $attrs = $attrs_of{refaddr $self};
1292 22         28 local $Contextual::Return::__RESULT__;
1293             handler:
1294 22         47 for my $context (qw(ARRAYREF REF)) {
1295             my $handler = $attrs->{$context}
1296             or $attrs->{STRICT} and last handler
1297 28 50 100     137 or next handler;
      66        
1298              
1299 15         26 local $Contextual::Return::uplevel = 2;
1300 15         28 my $rv = eval { $handler->(@{$attrs->{args}}) };
  15         20  
  15         53  
1301              
1302 15 100       998 if (my $recover = $attrs->{RECOVER}) {
    50          
1303 1 50       3 if (!$Contextual::Return::__RESULT__) {
1304 1         2 $Contextual::Return::__RESULT__ = [$rv];
1305             }
1306 1         1 scalar $recover->(@{$attrs->{args}});
  1         3  
1307             }
1308             elsif ($@) {
1309 0         0 die $@;
1310             }
1311              
1312 15 100       320 if ($Contextual::Return::__RESULT__) {
1313 5         8 $rv = $Contextual::Return::__RESULT__->[0];
1314             }
1315              
1316             # Catch bad behaviour...
1317 15 50 33     91 die _in_context "$context block did not return ",
1318             "a suitable reference to the array dereference"
1319             if ref($rv) ne 'ARRAY' && ref($rv) ne 'OBJ';
1320              
1321 15 100       82 if ( $attrs->{FIXED} ) {
    50          
1322 1         5 $_[0] = $rv;
1323             }
1324             elsif ( !$attrs->{ACTIVE} ) {
1325 14     0   77 $attrs->{$context} = sub { $rv };
  0         0  
1326             }
1327 15         93 return $rv;
1328             }
1329             handler:
1330 7         15 for my $context (qw(LIST VALUE NONVOID DEFAULT)) {
1331 9 100       19 last handler if $attrs->{STRICT};
1332 8 100       17 my $handler = $attrs->{$context}
1333             or next handler;
1334              
1335 6         6 local $Contextual::Return::uplevel = 2;
1336 6         9 my @rv = eval { $handler->(@{$attrs->{args}}) };
  6         8  
  6         11  
1337              
1338 6 50       36 if (my $recover = $attrs->{RECOVER}) {
    50          
1339 0 0       0 if (!$Contextual::Return::__RESULT__) {
1340 0         0 $Contextual::Return::__RESULT__ = [@rv];
1341             }
1342 0         0 () = $recover->(@{$attrs->{args}});
  0         0  
1343             }
1344             elsif ($@) {
1345 0         0 die $@;
1346             }
1347              
1348 6 50       12 if ($Contextual::Return::__RESULT__) {
1349 0         0 @rv = @{$Contextual::Return::__RESULT__->[0]};
  0         0  
1350             }
1351              
1352 6 100       16 if ( $attrs->{FIXED} ) {
    50          
1353 1         2 $_[0] = \@rv;
1354             }
1355             elsif ( !$attrs->{ACTIVE} ) {
1356 5     0   16 $attrs->{$context} = sub { @rv };
  0         0  
1357             }
1358 6         41 return \@rv;
1359             }
1360              
1361 1 50       3 if ($attrs->{STRICT}) {
1362 1         5 $@ = _in_context "Call to $attrs->{sub} didn't return an array reference, as required ";
1363 1 50       6 if (my $recover = $attrs->{RECOVER}) {
1364 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
1365             }
1366             else {
1367 1         6 die $@;
1368             }
1369             }
1370              
1371 0         0 return [ $self ];
1372             },
1373             '%{}' => sub {
1374 16     16   395 my ($self) = @_;
1375 16         29 local $Contextual::Return::__RETOBJ__ = $self;
1376 31     31   143 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         41  
  31         9251  
  16         31  
1377 16         55 my $attrs = $attrs_of{refaddr $self};
1378             handler:
1379 16         42 for my $context (qw(HASHREF REF NONVOID DEFAULT)) {
1380             my $handler = $attrs->{$context}
1381             or $attrs->{STRICT} and last handler
1382 16 0 50     75 or next handler;
      66        
1383              
1384 15         22 local $Contextual::Return::__RESULT__;
1385 15         22 local $Contextual::Return::uplevel = 2;
1386 15         27 my $rv = eval { $handler->(@{$attrs->{args}}) };
  15         23  
  15         52  
1387              
1388 15 100       121 if (my $recover = $attrs->{RECOVER}) {
    50          
1389 1 50       7 if (!$Contextual::Return::__RESULT__) {
1390 1         2 $Contextual::Return::__RESULT__ = [$rv];
1391             }
1392 1         2 scalar $recover->(@{$attrs->{args}});
  1         7  
1393             }
1394             elsif ($@) {
1395 0         0 die $@;
1396             }
1397              
1398 15 100       329 if ($Contextual::Return::__RESULT__) {
1399 5         8 $rv = $Contextual::Return::__RESULT__->[0];
1400             }
1401              
1402             # Catch bad behaviour...
1403 15 50 33     100 die _in_context "$context block did not return ",
1404             "a suitable reference to the hash dereference"
1405             if ref($rv) ne 'HASH' && ref($rv) ne 'OBJ';
1406              
1407 15 100       66 if ( $attrs->{FIXED} ) {
    50          
1408 1         1 $_[0] = $rv;
1409             }
1410             elsif ( !$attrs->{ACTIVE} ) {
1411 14     1   65 $attrs->{$context} = sub { $rv };
  1         2  
1412             }
1413 15         147 return $rv;
1414             }
1415 1         5 $@ = _in_context "Call to $attrs->{sub} didn't return a hash reference, as required ";
1416 1 50       3 if (my $recover = $attrs->{RECOVER}) {
1417 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
1418             }
1419             else {
1420 1         7 die $@;
1421             }
1422             },
1423             '&{}' => sub {
1424 7     7   367 my ($self) = @_;
1425 7         13 local $Contextual::Return::__RETOBJ__ = $self;
1426 31     31   237 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         47  
  31         9705  
  7         15  
1427 7         22 my $attrs = $attrs_of{refaddr $self};
1428             handler:
1429 7         17 for my $context (qw(CODEREF REF NONVOID DEFAULT)) {
1430             my $handler = $attrs->{$context}
1431             or $attrs->{STRICT} and last handler
1432 7 0 0     112 or next handler;
      33        
1433              
1434 7         60 local $Contextual::Return::__RESULT__;
1435 7         10 local $Contextual::Return::uplevel = 2;
1436 7         15 my $rv = eval { $handler->(@{$attrs->{args}}) };
  7         42  
  7         28  
1437              
1438 7 100       56 if (my $recover = $attrs->{RECOVER}) {
    50          
1439 1 50       3 if (!$Contextual::Return::__RESULT__) {
1440 1         3 $Contextual::Return::__RESULT__ = [$rv];
1441             }
1442 1         2 scalar $recover->(@{$attrs->{args}});
  1         3  
1443             }
1444             elsif ($@) {
1445 0         0 die $@;
1446             }
1447              
1448 7 100       300 if ($Contextual::Return::__RESULT__) {
1449 2         4 $rv = $Contextual::Return::__RESULT__->[0];
1450             }
1451              
1452             # Catch bad behaviour...
1453 7 50 33     30 die _in_context "$context block did not return ",
1454             "a suitable reference to the subroutine dereference"
1455             if ref($rv) ne 'CODE' && ref($rv) ne 'OBJ';
1456              
1457 7 100       28 if ( $attrs->{FIXED} ) {
    50          
1458 1         2 $_[0] = $rv;
1459             }
1460             elsif ( !$attrs->{ACTIVE} ) {
1461 6     0   22 $attrs->{$context} = sub { $rv };
  0         0  
1462             }
1463 7         29 return $rv;
1464             }
1465 0         0 $@ = _in_context "Call to $attrs->{sub} didn't return a subroutine reference, as required ";
1466 0 0       0 if (my $recover = $attrs->{RECOVER}) {
1467 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
1468             }
1469             else {
1470 0         0 die $@;
1471             }
1472             },
1473             '*{}' => sub {
1474 7     7   372 my ($self) = @_;
1475 7         13 local $Contextual::Return::__RETOBJ__ = $self;
1476 31     31   140 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         50  
  31         8884  
  7         12  
1477 7         29 my $attrs = $attrs_of{refaddr $self};
1478             handler:
1479 7         21 for my $context (qw(GLOBREF REF NONVOID DEFAULT)) {
1480             my $handler = $attrs->{$context}
1481             or $attrs->{STRICT} and last handler
1482 7 0 0     28 or next handler;
      33        
1483              
1484 7         11 local $Contextual::Return::__RESULT__;
1485 7         10 local $Contextual::Return::uplevel = 2;
1486 7         17 my $rv = eval { $handler->(@{$attrs->{args}}) };
  7         9  
  7         21  
1487              
1488 7 100       53 if (my $recover = $attrs->{RECOVER}) {
    50          
1489 1 50       2 if (!$Contextual::Return::__RESULT__) {
1490 1         2 $Contextual::Return::__RESULT__ = [$rv];
1491             }
1492 1         1 scalar $recover->(@{$attrs->{args}});
  1         3  
1493             }
1494             elsif ($@) {
1495 0         0 die $@;
1496             }
1497              
1498 7 100       289 if ($Contextual::Return::__RESULT__) {
1499 2         4 $rv = $Contextual::Return::__RESULT__->[0];
1500             }
1501              
1502             # Catch bad behaviour...
1503 7 50 33     32 die _in_context "$context block did not return ",
1504             "a suitable reference to the typeglob dereference"
1505             if ref($rv) ne 'GLOB' && ref($rv) ne 'OBJ';
1506              
1507 7 100       30 if ( $attrs->{FIXED} ) {
    50          
1508 1         3 $_[0] = $rv;
1509             }
1510             elsif ( !$attrs->{ACTIVE} ) {
1511 6     0   23 $attrs->{$context} = sub { $rv };
  0         0  
1512             }
1513 7         48 return $rv;
1514             }
1515 0         0 $@ = _in_context "Call to $attrs->{sub} didn't return a typeglob reference, as required ";
1516 0 0       0 if (my $recover = $attrs->{RECOVER}) {
1517 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
1518             }
1519             else {
1520 0         0 die $@;
1521             }
1522             },
1523 31     31   1699 );
1524             }
1525              
1526 31     31   49311 use overload %operator_impl, fallback => 1;
  31         27846  
  31         211  
1527              
1528             sub DESTROY {
1529 247     247   22839 my ($id) = refaddr shift;
1530 247         361 my $attrs = $attrs_of{$id};
1531 31     31   3826 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         39  
  31         9693  
  247         463  
1532 247 100       566 if (my $handler = $attrs->{CLEANUP}) {
1533 13         8 $handler->(@{ $attrs->{args} });
  13         24  
1534             }
1535 247         1997 delete $attrs_of{$id};
1536 247         2857 return;
1537             }
1538              
1539             my $NO_SUCH_METHOD = qr/\ACan't (?:locate|call)(?: class| object)? method/ms;
1540              
1541             # Forward metainformation requests to actual class...
1542             sub can {
1543 7     7   34 my ($invocant) = @_;
1544             # Only forward requests on actual C::R::V objects...
1545 7 100       22 if (ref $invocant) {
1546 6         8 our $AUTOLOAD = 'can';
1547 6         22 goto &AUTOLOAD;
1548             }
1549              
1550             # Refer requests on classes to actual class hierarchy...
1551 1         10 return $invocant->SUPER::can(@_[1..$#_]);
1552             }
1553              
1554             sub isa {
1555             # Only forward requests on actual C::R::V objects...
1556 2     2   12 my ($invocant) = @_;
1557 2 100       6 if (ref $invocant) {
1558 1         2 our $AUTOLOAD = 'isa';
1559 1         2 goto &AUTOLOAD;
1560             }
1561              
1562             # Refer requests on classes to actual class hierarchy...
1563 1         14 return $invocant->SUPER::isa(@_[1..$#_]);
1564             }
1565              
1566              
1567             sub AUTOLOAD {
1568 22     22   1032 my ($self) = @_;
1569 22         16 our $AUTOLOAD;
1570              
1571 22 100       118 my ($requested_method) = $AUTOLOAD =~ m{ .* :: (.*) }xms ? $1 : $AUTOLOAD;
1572              
1573 22   50     96 my $attrs = $attrs_of{refaddr $self} || {};
1574 22         25 local $Contextual::Return::__RETOBJ__ = $self;
1575 31     31   153 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         40  
  31         20679  
  22         34  
1576              
1577             # First, see if there is a method call handler...
1578 22 100       53 if (my $context_handler = $attrs->{METHOD}) {
1579 8         9 local $Contextual::Return::__RESULT__;
1580 8         7 local $Contextual::Return::uplevel = 2;
1581 8         9 my @method_handlers = eval { $context_handler->(@{$attrs->{args}}) };
  8         6  
  8         19  
1582              
1583 8 50       88 if (my $recover = $attrs->{RECOVER}) {
    50          
1584 0 0       0 if (!$Contextual::Return::__RESULT__) {
1585 0         0 $Contextual::Return::__RESULT__ = [\@method_handlers];
1586             }
1587 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
1588             }
1589             elsif ($@) {
1590 0         0 die $@;
1591             }
1592              
1593 8 50       13 if ($Contextual::Return::__RESULT__) {
1594 0         0 @method_handlers = @{$Contextual::Return::__RESULT__};
  0         0  
1595             }
1596              
1597             # Locate the correct method handler (if any)...
1598             MATCHER:
1599 8         21 while (my ($matcher, $method_handler) = splice @method_handlers, 0, 2) {
1600              
1601 16 100       104 if (ref($matcher) eq 'ARRAY') {
    100          
1602             next MATCHER
1603 3 100       4 if !grep { $requested_method =~ $_ } @{$matcher};
  6         42  
  3         4  
1604             }
1605             elsif ($requested_method !~ $matcher) {
1606 8         35 next MATCHER;
1607             }
1608              
1609 7         6 shift;
1610 7 50       14 if (wantarray) {
1611 0         0 my @result = eval {
1612 0         0 local $_ = $requested_method;
1613 0         0 $method_handler->($self,@_);
1614             };
1615 0 0       0 die _in_context $@ if $@;
1616 0         0 return @result;
1617             }
1618             else {
1619 7         6 my $result = eval {
1620 7         7 local $_ = $requested_method;
1621 7         18 $method_handler->($self,@_);
1622             };
1623 7 50       27 die _in_context $@ if $@;
1624 7         57 return $result;
1625             }
1626             }
1627             }
1628              
1629             # Next, try to create an object on which to call the method...
1630             handler:
1631 15         28 for my $context (qw(OBJREF STR SCALAR LAZY VALUE NONVOID DEFAULT)) {
1632             my $handler = $attrs->{$context}
1633             or $attrs->{STRICT} and last handler
1634 61 50 50     197 or next handler;
      66        
1635              
1636 10         11 local $Contextual::Return::__RESULT__;
1637 10         8 local $Contextual::Return::uplevel = 2;
1638 10         12 my $object = eval { $handler->(@{$attrs->{args}}) };
  10         11  
  10         25  
1639              
1640 10 50       56 if (my $recover = $attrs->{RECOVER}) {
    50          
1641 0 0       0 if (!$Contextual::Return::__RESULT__) {
1642 0         0 $Contextual::Return::__RESULT__ = [$object];
1643             }
1644 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
1645             }
1646             elsif ($@) {
1647 0         0 die $@;
1648             }
1649              
1650 10 50       17 if ($Contextual::Return::__RESULT__) {
1651 0         0 $object = $Contextual::Return::__RESULT__->[0];
1652             }
1653              
1654 10 100       27 if ( $attrs->{FIXED} ) {
    50          
1655 1         2 $_[0] = $object;
1656             }
1657             elsif ( !$attrs->{ACTIVE} ) {
1658 9     0   27 $attrs->{$context} = sub { $object };
  0         0  
1659             }
1660 10         12 shift;
1661              
1662 10 50       20 if (wantarray) {
1663 0         0 my @result = eval { $object->$requested_method(@_) };
  0         0  
1664 0         0 my $exception = $@;
1665 0 0       0 return @result if !$exception;
1666 0 0       0 die _in_context $exception if $exception !~ $NO_SUCH_METHOD;
1667             }
1668             else {
1669 10         9 my $result = eval { $object->$requested_method(@_) };
  10         53  
1670 10         27 my $exception = $@;
1671 10 100       37 return $result if !$exception;
1672 4 100       30 die _in_context $exception if $exception !~ $NO_SUCH_METHOD;
1673             }
1674 3         12 $@ = _in_context "Can't call method '$requested_method' on $context value returned by $attrs->{sub}";
1675 3 50       7 if (my $recover = $attrs->{RECOVER}) {
1676 0         0 scalar $recover->(@{$attrs->{args}});
  0         0  
1677             }
1678             else {
1679 3         18 die $@;
1680             }
1681             }
1682              
1683             # Otherwise, the method cannot be called, so react accordingly...
1684 5         24 $@ = _in_context "Can't call method '$requested_method' on value returned by $attrs->{sub}";
1685 5 50       16 if (my $recover = $attrs->{RECOVER}) {
1686 0         0 return scalar $recover->(@{$attrs->{args}});
  0         0  
1687             }
1688             else {
1689 5         167 die $@;
1690             }
1691             }
1692              
1693             package Contextual::Return::Lvalue;
1694              
1695             sub TIESCALAR {
1696 10     10   25 my ($package, @handler) = @_;
1697 10         53 return bless {@handler}, $package;
1698             }
1699              
1700             # Handle calls that are lvalues...
1701             sub STORE {
1702 3     3   11 local *CALLER::_ = \$_;
1703 3         7 local *_ = \$_[1];
1704 3         6 local $Contextual::Return::uplevel = 1;
1705 31     31   174 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         38  
  31         3290  
  3         6  
1706 3         5 local $Contextual::Return::__RESULT__;
1707              
1708 3         5 my $rv = $_[0]{LVALUE}( @{$_[0]{args}} );
  3         14  
1709              
1710 3 50       1354 return $rv if !$Contextual::Return::__RESULT__;
1711 0         0 return $Contextual::Return::__RESULT__->[0];
1712             }
1713              
1714             # Handle calls that are rvalues...
1715             sub FETCH {
1716 21     21   33 local $Contextual::Return::uplevel = 1;
1717 31     31   136 no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller;
  31         39  
  31         3736  
  21         32  
1718 21         20 local $Contextual::Return::__RESULT__;
1719              
1720 21 50       44 my $rv = $_[0]{RVALUE} ? $_[0]{RVALUE}( @{$_[0]{args}} ) : undef;
  21         64  
1721              
1722 21 50       389 return $rv if !$Contextual::Return::__RESULT__;
1723 0           return $Contextual::Return::__RESULT__->[0];
1724             }
1725              
1726       0     sub DESTROY {};
1727              
1728             1; # Magic true value required at end of module
1729              
1730             __END__