← Index
NYTProf Performance Profile   « line view »
For split.pl
  Run on Thu Apr 20 02:05:47 2023
Reported on Thu Apr 20 18:31:09 2023

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