Contextual-Return-0.004008/000755 000765 000765 00000000000 12574714434 014747 5ustar00damian000000 000000 Contextual-Return-0.004008/Changes000644 000765 000765 00000007471 12574714416 016253 0ustar00damian000000 000000 Revision history for Contextual-Return 0.0.1 Mon Mar 14 22:53:00 2005 Initial release. 0.0.2 Sun May 22 05:48:19 2005 - added dependency on version.pm 0.1.0 Fri Feb 17 12:15:18 2006 - added LAZY {...} block for better self-documentation - fixed propagation of exceptions from methods called on returned object - Added proxying of can() and isa(). (Should VERSION() be done as well?) (thanks, Rob) - Added FIXED() to support morphing of scalar return values (thanks, Rob) - BACKWARDS INCOMPATIBLE CHANGE: Added fallback to scalar returns for list context To get the old behavior, add: LIST { croak "Can't call this sub in list context" } - Made return values under ${} and @{} remain fully lazy (unless FIXED) - Added LVALUE, RVALUE, and NVALUE blocks for implementing lvalue returns - Added FAIL block for smart failure - Added Contextual::Return::FAIL_WITH to configure FAIL 0.2.0 Tue Mar 6 16:34:54 2007 - Fixed doc nit (thanks BrowserUK) - Fixed test suite under Windows (thanks Nigel and Doug) - Fixed doc bugs for FAIL_WITH - Removed dependency on Carp internals (now replaces them!) - Fixed VOID handling (now correctly falls back to DEFAULT) - Fixed caller semantics within handler blocks (thanks Schwern) - Fixed edge case of C::R::V metainformation requests (thanks Andrew) - Rejigged FIXED/LAZY/ACTIVE - Added RESULT and RECOVER blocks (thanks Aaron) 0.2.1 Thu Mar 29 17:59:40 2007 - Removed spurious Smart::Comments dependency (thanks Dave!) 0.003001 Tue Jun 22 17:20:36 2010 - Added Contextual::Return::FREEZE and Contextual::Return::DUMP to facilitate debugging - General clean-and-tighten of documentation - Added CLEANUP blocks - Added PUREBOOL context - [BACKWARDS INCOMPATIBLE CHANGE] Changed export interface - Added warning about (mis)behaviour of LVALUE, RVALUE, NVALUE under the debugger (thanks Steven) - Documented METHOD handlers 0.003002 Thu Jan 19 09:27:29 2012 - Updated version number of Contextual::Return::Failure to placate CPAN indexer - Improved error messages for bare handlers in bad contexts (thanks Mathew) - Work around problems with Test::More and caller 0.004000 Thu Feb 16 14:30:56 2012 - Fixed context propagation bugs in FIXED and ACTIVE modifiers - Added STRICT modifier to prevent fallbacks (i.e. impose strict typing on return values) 0.004001 Thu Feb 16 19:01:05 2012 - Fixed annoying POD nit (thanks Salvatore) 0.004002 Fri Mar 2 06:18:38 2012 - Fixed significant typo (Carp:carp -> Carp::carp) (thanks everyone who reported it) 0.004003 Wed Apr 11 07:55:49 2012 - Doc patch (thanks Fabrizio) - Patched failures.t to account from bleadperl changes (thanks Zefram!) 0.004004 Sun Aug 5 17:46:56 2012 - Further patch to failures.t - Added redefinition of Scalar::Util::blessed() to avoid nasty surprises (thanks Andrew!) - Added confess() and cluck() overrides and fixed caller() override to set @DB::args when appropriate 0.004005 Mon Aug 20 10:44:35 2012 - Further patch for t/confess.t (Thanks, David!) 0.004006 Thu Oct 4 16:49:47 2012 - Circumvented annoying undef-as-key warnings in Perl 5.17+ - Honour @CARP_NOT's when reporting context 0.004007 Fri Oct 5 23:05:05 2012 - Added BLESSED handler for better control over how blessed() lies - Upgraded reimplementation of blessed() to make more sense 0.004008 Sat Sep 12 13:16:30 2015 - Promoted $VERSION variable to earlier in source to attempt to placate cpanminus (thanks, Karen!) - Added prototype to overridden caller() - Changed way caller() is overridden, hopefully will no longer clash with Sub::Uplevel Contextual-Return-0.004008/lib/000755 000765 000765 00000000000 12574714432 015513 5ustar00damian000000 000000 Contextual-Return-0.004008/Makefile.PL000644 000765 000765 00000001130 11741622314 016702 0ustar00damian000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Contextual::Return', AUTHOR => 'Damian Conway ', VERSION_FROM => 'lib/Contextual/Return.pm', ABSTRACT_FROM => 'lib/Contextual/Return.pm', LICENSE => 'perl', PL_FILES => {}, PREREQ_PM => { 'Test::More' => 0, 'version' => 0, 'Want' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Contextual-Return-*' }, ); Contextual-Return-0.004008/MANIFEST000644 000765 000765 00000001302 12574714434 016074 0ustar00damian000000 000000 Changes MANIFEST Makefile.PL README lib/Contextual/Return.pm lib/Contextual/Return/Failure.pm t/00.load.t t/SCALAR.t t/args.t t/context_tests.t t/fail.t t/interp.t t/nonvoid.t t/object.t t/pod.t t/simple.t t/fail_with.t t/failures.t t/fixed.t t/lazy.t t/lvalue.t t/scalar-to-list.t t/RECOVER.t t/RECOVER_RESULT.t t/RECOVER_exception.t t/RECOVER_exception_RESULT.t t/args_RESULT.t t/caller.t t/simple_RESULT.t t/cleanup.t t/method.t t/retobj.t t/simple_export.t t/simple_prefix.t t/simple_rename.t t/try t/STRICT.t t/blessed.t t/confess.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Contextual-Return-0.004008/META.json000644 000765 000765 00000001666 12574714434 016401 0ustar00damian000000 000000 { "abstract" : "Create context-sensitive return values", "author" : [ "Damian Conway " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.142690", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Contextual-Return", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Test::More" : "0", "Want" : "0", "version" : "0" } } }, "release_status" : "stable", "version" : "0.004008" } Contextual-Return-0.004008/META.yml000644 000765 000765 00000001040 12574714432 016211 0ustar00damian000000 000000 --- abstract: 'Create context-sensitive return values' author: - 'Damian Conway ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.142690' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Contextual-Return no_index: directory: - t - inc requires: Test::More: '0' Want: '0' version: '0' version: '0.004008' Contextual-Return-0.004008/README000644 000765 000765 00000003206 12574714416 015630 0ustar00damian000000 000000 Contextual::Return version 0.004008 This module provides a collection of named blocks that allow a return statement to return different values depending on the context in which it's called. For example: use Contextual::Return; use Carp; sub foo { return BOOL { 1 } NUM { 7*6 } STR { 'forty-two' } LIST { 0..41 } HASHREF { {name => 'Arthur', species => 'EXTINCT'} } ARRAYREF { ['q'..'z'] } GLOBREF { \*STDOUT } CODEREF { croak 'I am not a code reference!'; } ; } # and later... if (my $foo = foo()) { # evals to 1 in boolean context for my $count (1..$foo) { # evals to 7*6 in numeric context print "$count: $foo is:\n" # evals to 'forty-two' in str context . " array: @{$foo}\n" # evals to 'q'..'z' in array context . " hash: $foo->{name} is $foo->{species}\n" # evals to hash in hashref context ; } print {$foo} $foo->(); # Your planet destroyed here } INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install Alternatively, to install with Module::Build, you can use the following commands: perl Build.PL ./Build ./Build test ./Build install DEPENDENCIES None. COPYRIGHT AND LICENCE Copyright (C) 2005, Damian Conway This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Contextual-Return-0.004008/t/000755 000765 000765 00000000000 12574714432 015210 5ustar00damian000000 000000 Contextual-Return-0.004008/t/00.load.t000644 000765 000765 00000000155 10712734156 016530 0ustar00damian000000 000000 use Test::More tests => 1; BEGIN { use_ok( 'Contextual::Return' ); } diag( "Testing Contextual::Return" ); Contextual-Return-0.004008/t/args.t000644 000765 000765 00000003175 10463161110 016317 0ustar00damian000000 000000 use Contextual::Return; sub foo { return VOID { $_[1] = 99 } BOOL { @_ > 0 } LIST { (@_) x 2 } NUM { scalar @_ } STR { join '|', @_ } SCALAR { $_[0] } SCALARREF { my $var = $_[0]; \$var } HASHREF { { args => \@_} } ARRAYREF { \@_ } ; } package Other; use Test::More 'no_plan'; my @arg_lists = ( [99], [], [99..101], ); for my $arg_list (@arg_lists) { my $call = 'foo(' . join(q{,}, @{$arg_list}) . ')'; is_deeply [ ::foo(@{$arg_list}) ], [(@{$arg_list})x2] => "list test on $call"; is do{ ::foo(@{$arg_list}) ? 'true' : 'false' }, do{ @{$arg_list} ? 'true' : 'false' } => "boolean test on $call"; is 0+::foo(@{$arg_list}), 0+@{$arg_list} => "number test on $call"; is "" . ::foo(@{$arg_list}), join('|',@{$arg_list}) => "string test on $call"; is ${::foo(@{$arg_list})}, $arg_list->[0] => "scalar test on $call"; is_deeply \%{::foo(@{$arg_list})}, { args => $arg_list } => "hash test on $call"; is_deeply \@{::foo(@{$arg_list})}, \@{$arg_list} => "array test on $call"; } my @real_args = 1..3; ::foo(@real_args); is_deeply \@real_args, [1,99,3] => "arg changes stick" Contextual-Return-0.004008/t/args_RESULT.t000644 000765 000765 00000003437 11176205506 017430 0ustar00damian000000 000000 use Contextual::Return; sub foo { return VOID { RESULT { $_[1] = 99 }; undef } BOOL { RESULT { @_ > 0 }; undef } LIST { RESULT { (@_) x 2 }; undef } NUM { RESULT { scalar @_ }; undef } STR { RESULT { join '|', @_ }; undef } SCALAR { RESULT { $_[0] }; undef } SCALARREF { RESULT { my $var = $_[0]; \$var }; undef } HASHREF { RESULT { { args => \@_} }; undef } ARRAYREF { RESULT { \@_ }; undef } ; } package Other; use Test::More 'no_plan'; my @arg_lists = ( [99], [], [99..101], ); for my $arg_list (@arg_lists) { my $call = 'foo(' . join(q{,}, @{$arg_list}) . ')'; is_deeply [ ::foo(@{$arg_list}) ], [(@{$arg_list})x2] => "list test on $call"; is do{ ::foo(@{$arg_list}) ? 'true' : 'false' }, do{ @{$arg_list} ? 'true' : 'false' } => "boolean test on $call"; is 0+::foo(@{$arg_list}), 0+@{$arg_list} => "number test on $call"; is "" . ::foo(@{$arg_list}), join('|',@{$arg_list}) => "string test on $call"; is ${::foo(@{$arg_list})}, $arg_list->[0] => "scalar test on $call"; is_deeply \%{::foo(@{$arg_list})}, { args => $arg_list } => "hash test on $call"; is_deeply \@{::foo(@{$arg_list})}, \@{$arg_list} => "array test on $call"; } my @real_args = 1..3; ::foo(@real_args); is_deeply \@real_args, [1,99,3] => "arg changes stick" Contextual-Return-0.004008/t/blessed.t000644 000765 000765 00000006720 12033650574 017017 0ustar00damian000000 000000 use Contextual::Return; sub blessed_obj { return bless {}, 'Blessed' } sub unblessed_obj { return 42 } sub blessed_OBJREF { return OBJREF { bless {}, 'Blessed' } } sub blessed_REF { return REF { bless {}, 'Blessed' } } sub blessed_SCALAR { return SCALAR { bless {}, 'Blessed' } } sub blessed_VALUE { return VALUE { bless {}, 'Blessed' } } sub blessed_NONVOID { return NONVOID { bless {}, 'Blessed' } } sub blessed_DEFAULT { return DEFAULT { bless {}, 'Blessed' } } sub blessed_BLESSED { return BLESSED { 'EXPLICITLY_BLESSED' } } sub unblessed_OBJREF { return OBJREF { 'unblessed' } } sub unblessed_REF { return REF { 'unblessed' } } sub unblessed_SCALAR { return SCALAR { 'unblessed' } } sub unblessed_VALUE { return VALUE { 'unblessed' } } sub unblessed_NONVOID { return NONVOID { 'unblessed' } } sub unblessed_DEFAULT { return DEFAULT { 'unblessed' } } sub unblessed_BLESSED { return BLESSED { undef } } package Other; use Test::More 'no_plan'; use Scalar::Util 'blessed'; is ref( ::blessed_obj ()), 'Blessed' => 'ref blessed obj '; is ref( ::blessed_OBJREF ()), 'Contextual::Return::Value' => 'ref blessed OBJREF '; is ref( ::blessed_REF ()), 'Contextual::Return::Value' => 'ref blessed REF '; is ref( ::blessed_SCALAR ()), 'Contextual::Return::Value' => 'ref blessed SCALAR '; is ref( ::blessed_VALUE ()), 'Contextual::Return::Value' => 'ref blessed VALUE '; is ref( ::blessed_NONVOID()), 'Contextual::Return::Value' => 'ref blessed NONVOID'; is ref( ::blessed_DEFAULT()), 'Contextual::Return::Value' => 'ref blessed DEFAULT'; is ref( ::blessed_BLESSED()), 'Contextual::Return::Value' => 'ref blessed BLESSED'; is ref( ::unblessed_obj ()), q{} => 'ref unblessed obj '; is ref( ::unblessed_OBJREF ()), 'Contextual::Return::Value' => 'ref unblessed OBJREF '; is ref( ::unblessed_REF ()), 'Contextual::Return::Value' => 'ref unblessed REF '; is ref( ::unblessed_SCALAR ()), 'Contextual::Return::Value' => 'ref unblessed SCALAR '; is ref( ::unblessed_VALUE ()), 'Contextual::Return::Value' => 'ref unblessed VALUE '; is ref( ::unblessed_NONVOID()), 'Contextual::Return::Value' => 'ref unblessed NONVOID'; is ref( ::unblessed_DEFAULT()), 'Contextual::Return::Value' => 'ref unblessed DEFAULT'; is ref( ::unblessed_BLESSED()), 'Contextual::Return::Value' => 'ref unblessed BLESSED'; is blessed( ::blessed_obj ()), 'Blessed' => 'blessed obj '; is blessed( ::blessed_OBJREF ()), 'Blessed' => 'blessed OBJREF '; is blessed( ::blessed_REF ()), 'Blessed' => 'blessed REF '; is blessed( ::blessed_SCALAR ()), 'Blessed' => 'blessed SCALAR '; is blessed( ::blessed_VALUE ()), 'Blessed' => 'blessed VALUE '; is blessed( ::blessed_NONVOID()), 'Blessed' => 'blessed NONVOID'; is blessed( ::blessed_DEFAULT()), 'Blessed' => 'blessed DEFAULT'; is blessed( ::blessed_BLESSED()), 'EXPLICITLY_BLESSED' => 'blessed BLESSED'; is blessed(::unblessed_obj ()), undef() => 'unblessed obj '; is blessed(::unblessed_OBJREF ()), undef() => 'unblessed OBJREF '; is blessed(::unblessed_REF ()), undef() => 'unblessed REF '; is blessed(::unblessed_SCALAR ()), undef() => 'unblessed SCALAR '; is blessed(::unblessed_VALUE ()), undef() => 'unblessed VALUE '; is blessed(::unblessed_NONVOID()), undef() => 'unblessed NONVOID'; is blessed(::unblessed_DEFAULT()), undef() => 'unblessed DEFAULT'; is blessed(::unblessed_BLESSED()), undef() => 'unblessed BLESSED'; Contextual-Return-0.004008/t/caller.t000644 000765 000765 00000002260 12353024501 016621 0ustar00damian000000 000000 use Contextual::Return; *foo = sub { return LIST { [caller()], [caller(1)] } SCALAR { (caller()||q{}) . '|' . (caller(1)||q{}) } ; }; *bar = sub { return [CORE::caller()], [CORE::caller(1)] if wantarray; return (CORE::caller()||q{}) . '|' . (CORE::caller(1)||q{}); }; # This has to be on one line so the caller lines are the same... *foo_2 = sub { return &foo; }; *bar_2 = sub { return &bar; }; package Other; use Test::More 'no_plan'; # This has to be on one line so the caller lines are the same... my @caller_foo = ::foo(); *::foo = *::bar; my @caller_bar = ::foo(); is_deeply [ \@caller_foo ], [ \@caller_bar ] => 'Caller same both ways'; # This has to be on one line so the caller lines are the same... my @caller_foo_2 = ::foo_2(); *::foo_2 = *::bar_2; my @caller_bar_2 = ::foo_2(); is_deeply [ \@caller_foo_2 ], [ \@caller_bar_2 ] => 'Caller 2 same both ways'; my $caller_foo = ::foo(); *::foo = *::bar; my $caller_bar = ::foo(); is $caller_foo, $caller_bar => 'Scalar caller same both ways'; my $caller_foo_2 = ::foo_2(); *::foo = *::bar; my $caller_bar_2 = ::foo_2(); is $caller_foo_2, $caller_bar_2 => 'Scalar caller 2 same both ways'; Contextual-Return-0.004008/t/cleanup.t000644 000765 000765 00000003410 10707351412 017011 0ustar00damian000000 000000 use Contextual::Return; sub bar { return 'in bar'; } sub foo { return BOOL { 0 } LIST { 1,2,3 } NUM { 42 } STR { 'forty-two' } SCALAR { 86 } SCALARREF { \7 } HASHREF { { name => 'foo', value => 99} } ARRAYREF { [3,2,1] } GLOBREF { \*STDERR } CODEREF { \&bar } CLEANUP { Other::ok(1 => 'CLEANUP') } ; } package Other; use Test::More tests=>27; is_deeply [ ::foo() ], [1,2,3] => 'LIST context'; is do{ ::foo() ? 'true' : 'false' }, 'false' => 'BOOLEAN context'; is 0+::foo(), 42 => 'NUMERIC context'; is "".::foo(), 'forty-two' => 'STRING context'; is ${::foo}, 7 => 'SCALARREF context'; is_deeply \%{::foo()}, { name => 'foo', value => 99} => 'HASHREF context'; is_deeply \@{::foo()}, [3,2,1] => 'ARRAYREF context'; is \*{::foo()}, \*STDERR => 'GLOBREF context'; is ::foo->(), 'in bar' => 'ARRAYREF context'; $foo = ::foo(); is ${$foo}, 7 => 'SCALARREF via var'; $foo = undef; my ($void, $tested); sub side_effect { use Contextual::Return; return BOOL { $tested = 1 } VOID { $void = 1 } CLEANUP { $_ = 42 if $tested } }; side_effect(); is $void, 1 => 'SIDE EFFECT VOID'; ok !defined $_ => 'NO ASSIGNMENT TO $_'; undef $void; my $side_effect = side_effect(); ok !defined $void => 'SIDE EFFECT NONVOID'; ok !defined $_ => 'NO ASSIGNMENT TO $_'; ok side_effect() => 'SIDE EFFECT BOOLEAN'; ok !defined $void => 'SIDE EFFECT BOOLEAN NONVOID'; is $_, 42 => 'ASSIGNMENT TO $_'; Contextual-Return-0.004008/t/confess.t000644 000765 000765 00000000634 12014303773 017027 0ustar00damian000000 000000 use Contextual::Return; use Carp; use Test::More tests => 3; sub f { Carp::confess("Forgive me..."); }; ok !defined eval { f() } => 'eval fails'; my $exception = $@; like $exception, qr{line\s${\(__LINE__-3)}\.?\n.*line\s${\(__LINE__-2)}}xms => 'error message'; unlike $exception, qr{\*\* Incomplete caller override detected; \@DB::args were not set \*\*} => 'Complete override'; Contextual-Return-0.004008/t/context_tests.t000644 000765 000765 00000001437 10243572461 020303 0ustar00damian000000 000000 use Contextual::Return; use Test::More 'no_plan'; sub foo { my ($expected) = @_; if (VOID) { is $expected, 'void' => 'VOID test'; } elsif (LIST) { is $expected, 'list' => 'LIST test'; } elsif (SCALAR) { is $expected, 'scalar' => 'SCALAR test'; } else { ok 0 => 'bizarre behaviour' } } my @foo = foo( 'list' ); my $foo = foo( 'scalar' ); foo( 'void' ); sub bar { my ($expected) = @_; if (VOID) { is $expected, 'void' => 'VOID test'; } elsif (NONVOID) { isnt $expected, 'void' => "NONVOID(\U$expected\E) test"; } else { ok 0 => 'bizarre behaviour' } } my @bar = bar( 'list' ); my $bar = bar( 'scalar' ); bar( 'void' ); Contextual-Return-0.004008/t/fail.t000644 000765 000765 00000003473 12012426340 016300 0ustar00damian000000 000000 use Contextual::Return qw< FAIL FAIL_WITH >; use Test::More 'no_plan'; sub eval_nok(&$$) { my ($block, $exception_pat, $message) = @_; my (undef, $file, $line) = caller; eval { $block->() }; my $exception = $@; ok $exception => $message; like $exception, qr/\Q$exception_pat\E at \Q$file\E line $line/ => "Right message"; } sub fail_with_message { return FAIL { 'fail_with_message() failed' } } if ( my $result = ::fail_with_message() ) { ok 0 => 'Unexpected succeeded in bool context'; } else { ok 1 => 'Failed as expected in bool context'; like $result->error, qr/^fail_with_message\(\) failed/ => 'Failed with expected message'; } eval_nok { fail_with_message() } 'fail_with_message() failed' => 'Exception thrown in void context'; eval_nok { () = fail_with_message() } 'fail_with_message() failed' => 'Exception thrown in list context'; eval_nok { my $x = fail_with_message(); $x+1 } 'fail_with_message() failed' => 'Exception thrown in num context'; eval_nok { my $x = fail_with_message(); $x.'a' } 'fail_with_message() failed' => 'Exception thrown in str context'; sub fail_auto_message { return FAIL; } if ( ::fail_auto_message() ) { ok 0 => 'Unexpected succeeded in bool context'; } else { ok 1 => 'Failed as expected in bool context'; } eval_nok { fail_auto_message() } 'Call to main::fail_auto_message() failed' => 'Exception thrown in void context'; eval_nok { () = fail_auto_message() } 'Call to main::fail_auto_message() failed' => 'Exception thrown in list context'; eval_nok { my $x = fail_auto_message(); $x+1 } 'Call to main::fail_auto_message() failed' => 'Exception thrown in num context'; eval_nok { my $x = fail_auto_message(); $x.'a' } 'Call to main::fail_auto_message() failed' => 'Exception thrown in str context'; Contextual-Return-0.004008/t/fail_with.t000644 000765 000765 00000006464 12012426430 017336 0ustar00damian000000 000000 use Contextual::Return qw< FAIL FAIL_WITH >; use Carp; my $FAIL_SPEC_ref; sub set_up_1 { package Other; use Contextual::Return; use Carp; $FAIL_SPEC_ref = { good => sub { BOOL { 0 } DEFAULT { croak 'good'} }, bad => sub { BOOL { 1 } DEFAULT { () } }, ugly => sub { BOOL { undef } DEFAULT { confess 'ugly'} }, }; Contextual::Return::FAIL_WITH $FAIL_SPEC_ref, qw(oh be a good boy); sub fail_auto_message { return FAIL; } } set_up_1(); use Test::More qw( no_plan ); sub eval_nok(&$$) { my ($block, $exception_pat, $message) = @_; my (undef, $file, $line) = caller; eval { $block->() }; my $exception = $@; ok $exception => $message; like $exception, qr/\Q$exception_pat\E at \Q$file\E line $line/ => "Right message"; } if ( Other::fail_auto_message() ) { ok 0 => 'Unexpected succeeded in bool context'; } else { ok 1 => 'Failed as expected in bool context'; } eval_nok { Other::fail_auto_message() } 'good' => 'Exception thrown in void context'; eval_nok { () = Other::fail_auto_message() } 'good' => 'Exception thrown in list context'; eval_nok { my $x = Other::fail_auto_message(); $x+1 } 'good' => 'Exception thrown in num context'; eval_nok { my $x = Other::fail_auto_message(); $x.'a' } 'good' => 'Exception thrown in str context'; sub set_up_2 { package Other; my $LINE = (caller)[2]; local $SIG{__WARN__} = sub { my $message = shift; ::is $message, 'FAIL handler for package Other redefined at '.__FILE__ ." line $LINE\n" => 'Redefinition warning as expected' }; Contextual::Return::FAIL_WITH -fail => $FAIL_SPEC_ref, qw(if you fail good -fail bad); } set_up_2(); if ( Other::fail_auto_message() ) { ok 1 => 'Succeeded as expected in bool context'; } else { ok 0 => 'Unexpected failed in bool context'; } my @results = Other::fail_auto_message(); ok @results == 0 => 'Returned empty list in list context'; sub set_up_3 { package Other; my $LINE = (caller)[2]; local $SIG{__WARN__} = sub { my $message = shift; ::is $message, 'FAIL handler for package Other redefined at '.__FILE__ ." line $LINE\n" => 'Redefinition warning as expected' }; eval { Contextual::Return::FAIL_WITH -fail => $FAIL_SPEC_ref, -fail => 'unknown'; }; my $exception = $@; ::ok $exception => "Unknown FAIL handler, as expected"; ::like $exception, qr/Invalid option: -fail => unknown/ => 'Correct exception thrown'; local $SIG{__WARN__} = sub { my $message = shift; ::is $message, 'FAIL handler for package Other redefined at '.__FILE__ ." line $LINE\n" => 'Redefinition warning as expected' }; Contextual::Return::FAIL_WITH -fail => {}, -fail => sub { undef }; } set_up_3(); if ( Other::fail_auto_message() ) { ok 0 => 'Unexpected succeeded in bool context'; } else { ok 1 => 'Failed as expected in bool context'; } my $result = Other::fail_auto_message(); ok !defined $result => 'Scalar context was undef'; my @results2 = Other::fail_auto_message(); ok @results2 == 1 => 'Returned one-elem list in list context'; ok !defined $results2[0] => 'One-elem was undef'; Contextual-Return-0.004008/t/failures.t000644 000765 000765 00000004664 12352707426 017220 0ustar00damian000000 000000 use Contextual::Return; use Test::More 'no_plan'; use Carp qw< croak cluck confess >; sub foo { return BOOL { cluck 'oops! Bool'; 1 } NUM { cluck 'oops! Num'; return 7; } ARRAYREF { cluck 'oops! Array'; return [1,2]; } HASHREF { {name=>'foo', value=>42 } } VOID { confess 'Enter not the Abyss!'; } ; } sub ok_if_warn { my ($msg, $line) = @_; return sub { # diag( "Caught warning: '@_'" ); ok $_[0] =~ $msg => "Warn msg correct at line $line"; ok $_[0] =~ /line $line\.?\Z/ => "Line number correct at line $line" if $line; } } local $SIG{__WARN__} = ok_if_warn 'oops! Bool', __LINE__+1; if (my $foo = foo()) { local $SIG{__WARN__} = ok_if_warn 'oops! Bool', __LINE__+1; ok +($foo?1:0) => 'BOOLEAN'; local $SIG{__WARN__} = ok_if_warn 'oops! Num', __LINE__+1; ok "$foo" => 'STRING'; local $SIG{__WARN__} = ok_if_warn 'oops! Array', __LINE__+1; ok $foo->[0] => 'ARRAYREF'; local $SIG{__WARN__} = sub { ok 0 => "Unexpected warning: @_" }; is $foo->{name}, 'foo' => 'HASHREF (name)'; is $foo->{value}, 42 => 'HASHREF (value)'; } local $SIG{__WARN__} = ok_if_warn 'oops! Array', __LINE__+1; my @bar = foo(); ok @bar => 'LIST via ARRAYREF'; my $line = __LINE__+1; ok !eval { foo(); 1 } => 'VOID is fatal'; like $@, qr/Abyss/ => 'Error message is correct'; like $@, qr/line $line\Z/ => 'Error line is correct'; sub double_or_nothing { return LIST { 1..9 } NUM { 10 } LIST { 11..100 }; } eval { double_or_nothing(); }; my $exception = $@; ok $exception => 'Exception on repetition'; like $exception, qr/Can't install two LIST handlers/ => 'Correct exception'; eval "use Contextual::Return 'HANDLER'; "; use Data::Dumper 'Dumper'; $exception = $@; ok $exception => 'Exception on bad export name'; like $exception, qr/^Can't export HANDLER: no such handler/ => 'Correct exception'; eval "use Contextual::Return {HANDLER=>'FOO'}; "; use Data::Dumper 'Dumper'; $exception = $@; ok $exception => 'Exception on bad export type'; like $exception, qr/^Can't use HASH as export specifier/ => 'Correct exception'; local $SIG{__WARN__} = ok_if_warn q{didn't export anything}; eval 'use Contextual::Return qr/HANDLER/'; Contextual-Return-0.004008/t/fixed.t000644 000765 000765 00000007352 11717062120 016467 0ustar00damian000000 000000 use Contextual::Return; sub foo { return FIXED ( BOOL { 0 } LIST { 1,2,3 } NUM { 42 } STR { 'forty-two' } SCALAR { 86 } SCALARREF { \7 } HASHREF { { name => 'foo', value => 99} } ARRAYREF { [3,2,1] } GLOBREF { \*STDERR } CODEREF { \&baz } OBJREF { bless {}, 'Bar' } ); } sub bar { return FIXED STR { 'forty-two' } LIST { 1,2,3 } ; } sub bar_list { return FIXED STR { 'forty-two' } LIST { 1,2,3 } ; } sub baz { return 'in baz'; } package Other; use Test::More 'no_plan'; # We only need to test the scalar contexts, because LIST and VOID are # optimized out by checks against wantarray(). my $CLASS = 'Contextual::Return::Value'; my $bool = ::foo(); is ref($bool), $CLASS => 'Before usage, it is a C::R::V'; is do{ $bool ? 'true' : 'false' }, 'false' => 'BOOLEAN context'; isnt ref($bool), $CLASS => 'After usage, it is not a C::R::V'; my $num = ::foo(); is ref($num), $CLASS => 'Before usage, it is a C::R::V'; is $num+0, 42 => 'NUMERIC context'; isnt ref($num), $CLASS => 'After usage, it is not a C::R::V'; my $str = ::foo(); is ref($str), $CLASS => 'Before usage, it is a C::R::V'; is "".$str, 'forty-two' => 'STRING context'; isnt ref($str), $CLASS => 'After usage, it is not a C::R::V'; my $sref = ::foo(); is ref($sref), $CLASS => 'Before usage, it is a C::R::V'; is ${$sref}, 7 => 'SCALARREF context'; isnt ref($sref), $CLASS => 'After usage, it is not a C::R::V'; my $sref2 = ::bar(); is ref($sref2), $CLASS => 'Before usage, it is a C::R::V'; is ${$sref2}, 'forty-two' => 'SCALARREF context (no SCALARREF provided)'; isnt ref($sref2), $CLASS => 'After usage, it is not a C::R::V'; my $href = ::foo(); is ref($href), $CLASS => 'Before usage, it is a C::R::V'; is_deeply \%{$href}, { name => 'foo', value => 99} => 'HASHREF context'; isnt ref($href), $CLASS => 'After usage, it is not a C::R::V'; my $aref = ::foo(); is ref($aref), $CLASS => 'Before usage, it is a C::R::V'; is_deeply \@{$aref}, [3,2,1] => 'ARRAYREF context'; isnt ref($aref), $CLASS => 'After usage, it is not a C::R::V'; my $aref2 = ::bar(); is ref($aref2), $CLASS => 'Before usage, it is a C::R::V'; is_deeply \@{$aref2}, [1,2,3] => 'ARRAYREF context (no ARRAYREF provided)'; isnt ref($aref2), $CLASS => 'After usage, it is not a C::R::V'; my $gref = ::foo(); is ref($gref), $CLASS => 'Before usage, it is a C::R::V'; is \*{$gref}, \*STDERR => 'GLOBREF context'; isnt ref($gref), $CLASS => 'After usage, it is not a C::R::V'; my $cref = ::foo(); is ref($cref), $CLASS => 'Before usage, it is a C::R::V'; is $cref->(), 'in baz' => 'CODEREF context'; isnt ref($cref), $CLASS => 'After usage, it is not a C::R::V'; my $oref = ::foo(); is ref($oref), $CLASS => 'Before usage, it is a C::R::V'; is $oref->bar, "baaaaa!\n" => 'OBJREF context'; isnt ref($oref), $CLASS => 'After usage, it is not a C::R::V'; my @bar_list = ::bar_list(); is_deeply \@bar_list, [1,2,3] => 'List context works correctly'; package Bar; sub bar { return "baaaaa!\n"; } Contextual-Return-0.004008/t/interp.t000644 000765 000765 00000003660 10324203014 016657 0ustar00damian000000 000000 use Contextual::Return; use Test::More 'no_plan'; my @todo_list = ( 'eat', 'drink', 'be merry' ); sub interp_explicit { return ( SCALAR { scalar @todo_list } # In scalar context: how many? LIST { @todo_list } # In list context: what are they? SCALARREF { \scalar @todo_list } # Scalar context value as ref ARRAYREF { \@todo_list } # List context value as array ref ); } sub interp_implicit { return ( SCALAR { scalar @todo_list } # In scalar context: how many? LIST { @todo_list } # In list context: what are they? ); } sub interp_num { return ( NUM { scalar @todo_list } # In num context: how many? LIST { @todo_list } # In list context: what are they? ); } sub interp_str { return ( NUM { @todo_list + 1 } # In num context: how many + 1? STR { scalar @todo_list } # In str context: how many? LIST { @todo_list } # In list context: what are they? ); } is "There are ${interp_explicit()} ToDo tasks: @{interp_explicit()}", 'There are 3 ToDo tasks: eat drink be merry' => 'Explicit interpolators'; is "There are ${interp_implicit()} ToDo tasks: @{interp_implicit()}", 'There are 3 ToDo tasks: eat drink be merry' => 'Implicit interpolators'; is "There are ${interp_num()} ToDo tasks: @{interp_num()}", 'There are 3 ToDo tasks: eat drink be merry' => 'Numeric interpolators'; is "There are ${interp_str()} ToDo tasks: @{interp_str()}", 'There are 3 ToDo tasks: eat drink be merry' => 'String interpolators'; is 0+${interp_str()}, "4" => 'Smart numbers'; is "".${interp_str()}, "3" => 'Smart strings'; Contextual-Return-0.004008/t/lazy.t000644 000765 000765 00000000456 10305746107 016353 0ustar00damian000000 000000 use Contextual::Return; sub foo { return LAZY { print "ok 3 # In lazy eval of foo()\n"; 'foo' } } print "1..4\n"; print "ok 1 # Before call to foo()\n"; my $foo = foo(); print "ok 2 # After call to foo()\n"; print "not " unless $foo eq 'foo'; print "ok 4 # After lazy eval of foo()\n"; Contextual-Return-0.004008/t/lvalue.t000644 000765 000765 00000002307 11662122013 016650 0ustar00damian000000 000000 use Test::More 'no_plan'; use Contextual::Return; { sub foo : lvalue { my $x = 0; my $wantarray = wantarray; RVALUE { BOOL { $x > 0 } STR { "[$x]" } NUM { $x } } LVALUE { $x = $_[0] * $_; is $CALLER::_, 'wunderbar' => 'Caller::_'; } NVALUE { ok !defined $wantarray => 'NVALUE context'; } } } $_ = 'wunderbar'; for my $foo (foo 10) { is $foo+0, 0 => "Pre-numerication"; is "$foo", "[0]" => "Pre-stringification"; ok !$foo => "Pre-boolification"; $foo = 99; is $foo+0, 990 => "Post-numerication"; is "$foo", "[990]" => "Post-stringification"; ok $foo => "Post-boolification"; } is 0+foo, 0 => "Ex-numerication"; is "".foo, "[0]" => "Ex-stringification"; ok !foo() => "Ex-boolification"; foo(1) = 99; is 0+foo, 0 => "Ex-post-numerication"; is "".foo, "[0]" => "Ex-post-stringification"; ok !$foo => "Ex-post-boolification"; foo(); my $f = \foo(); { sub foo2 : lvalue { LVALUE { ok 1; } } } for my $foo (foo2) { $foo = 99; } Contextual-Return-0.004008/t/method.t000644 000765 000765 00000002517 11050510677 016653 0ustar00damian000000 000000 use Contextual::Return; use Test::More 'no_plan'; use strict; sub foo_with_default_method { return METHOD { bar => sub { 'bar method called' }, qr/ba(.)/ => sub { $1 . ' method called' }, ['qux','dux'] => sub { "$_ method called" }, qr/.*/ => sub { 'DEFAULT method called' }, } DEFAULT { 'DEFAULT value' } } is foo_with_default_method()->bar, 'bar method called', 'bar method'; is foo_with_default_method()->baz, 'z method called', 'baz method'; is foo_with_default_method()->qux, 'qux method called', 'qux method'; is foo_with_default_method()->dux, 'dux method called', 'dux method'; is foo_with_default_method()->jax, 'DEFAULT method called', 'DEFAULT method'; is foo_with_default_method() , 'DEFAULT value', 'DEFAULT'; sub foo_with_method_and_obj { return METHOD { bar => sub { 'bar method called' }, } OBJREF { bless {}, 'Bar'; } DEFAULT { 'DEFAULT value' } } is foo_with_method_and_obj()->bar, 'bar method called', 'bar method called'; is foo_with_method_and_obj()->baz, 'Bar::baz', 'OBJREF method called'; is foo_with_method_and_obj() , 'DEFAULT value', 'DEFAULT value'; package Bar; sub baz { "Bar::baz" } Contextual-Return-0.004008/t/nonvoid.t000644 000765 000765 00000001240 10604632635 017042 0ustar00damian000000 000000 use Contextual::Return; use Test::More 'no_plan'; use Carp; sub foo { return NONVOID { 4.2, 9.9 } VOID { die 'Useless use of foo() in void context' } ; } # and later... $foo = foo(); ok $foo => 'BOOLEAN context'; is 0+$foo, 9.9 => 'NUMERIC context'; is "$foo", 9.9 => 'STRING context'; is join(q{,}, foo()), '4.2,9.9' => 'LIST context'; my $res = eval{ ;foo(); 1; }; my $exception = $@; ok !$res => 'VOID context fails'; like $exception, qr/\QUseless use of foo() in void context/ => 'Error msg correct'; Contextual-Return-0.004008/t/object.t000644 000765 000765 00000003652 11050254201 016626 0ustar00damian000000 000000 use Contextual::Return; use Test::More 'no_plan'; ok(Contextual::Return::Value->isa('UNIVERSAL') => 'Handles class isa ok'); ok(Contextual::Return::Value->can('can') => 'Handles class can ok'); sub foo_no_obj { return VALUE { bless {}, 'Bar' } ; } sub foo_with_obj { return VALUE { 1 } OBJREF { bless {}, 'Bar' } ; } sub foo_bad_obj { return VALUE { 1 } OBJREF { 1 } ; } is foo_no_obj()->bar, "baaaaa!\n" => 'VALUE returns object'; ok !eval{ foo_no_obj()->baz } => 'Object has no baz() method'; like $@, qr/\A\QCan't call method 'baz' on VALUE value returned by main::foo_no_obj/ => 'Error msg was correct'; is foo_with_obj()->bar, "baaaaa!\n" => 'OBJREF returns object'; ok !eval{ foo_with_obj()->baz } => 'Object still has no baz() method'; like $@, qr/\A\QCan't call method 'baz' on OBJREF value returned by main::foo_with_obj/ => 'Error msg was also correct'; ok !eval{ foo_bad_obj()->bar } => 'OBJREF returns bad object'; like $@, qr/\A\QCan't call method 'bar' on OBJREF value returned by main::foo_bad_obj/ => 'Error msg was still correct'; ok !eval{ foo_with_obj()->bad } => 'Other exceptions propagated'; like $@, qr/\ABad method! No biscuit!/ => 'Exception msg was correct'; # can_ok() checks against ref $proto || $proto. This bypasses the the # obj de-ref that C::R::V provides. isa_ok() does check against the # object, but I chose to write it as ok( $foo->isa() ) to maintain # consistency and to provide the testname ok foo_no_obj()->can('bar') => 'can() is checked against the object, not C::R::V'; ok foo_no_obj()->isa('Bar') => 'isa() is checked against the object, not C::R::V'; package Bar; sub bar { "baaaaa!\n" } sub bad { die "Bad method! No biscuit!"; } Contextual-Return-0.004008/t/pod.t000644 000765 000765 00000000214 10215412714 016140 0ustar00damian000000 000000 #!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Contextual-Return-0.004008/t/RECOVER.t000644 000765 000765 00000002202 11176205340 016464 0ustar00damian000000 000000 use Contextual::Return; use Test::More tests => 18; sub bar { return 'in bar'; } sub foo { return BOOL { 0 } NUM { 42 } LIST { 1,2,3 } STR { 'forty-two' } SCALAR { 86 } SCALARREF { \7 } HASHREF { { name => 'foo', value => 99} } ARRAYREF { [3,2,1] } GLOBREF { \*STDERR } CODEREF { \&bar } RECOVER { ok 1 => 'Recovered' } ; } package Other; use Test::More; is_deeply [ ::foo() ], [1,2,3] => 'LIST context'; is do{ ::foo() ? 'true' : 'false' }, 'false' => 'BOOLEAN context'; is 0+::foo(), 42 => 'NUMERIC context'; is "".::foo(), 'forty-two' => 'STRING context'; is ${::foo}, 7 => 'SCALARREF context'; is_deeply \%{::foo()}, { name => 'foo', value => 99} => 'HASHREF context'; is_deeply \@{::foo()}, [3,2,1] => 'ARRAYREF context'; is \*{::foo()}, \*STDERR => 'GLOBREF context'; is ::foo->(), 'in bar' => 'ARRAYREF context'; Contextual-Return-0.004008/t/RECOVER_exception.t000644 000765 000765 00000001106 10517331512 020543 0ustar00damian000000 000000 use Contextual::Return; use Test::More tests => 8; no warnings 'uninitialized'; sub foo { return BOOL { die 'oops! Bool'; 1 } NUM { die 'oops! Num'; return 7; } STR { die 'oops! Num'; return 7; } VOID { die 'Enter not the Abyss!'; } RECOVER { ok 1 => "Recovered"; } ; } my $foo = foo(); ok +($foo?0:1) => 'BOOLEAN'; ok not("$foo") => 'STRING'; ok not(0+$foo) => 'NUM'; ok do{;foo;1} => 'VOID'; Contextual-Return-0.004008/t/RECOVER_exception_RESULT.t000644 000765 000765 00000001044 10516653333 021651 0ustar00damian000000 000000 use Contextual::Return; use Test::More tests => 6; no warnings 'uninitialized'; sub foo { return BOOL { die 'oops! Bool'; 1 } NUM { die 'oops! Num'; return 7; } STR { die 'oops! Num'; return 7; } VOID { die 'Enter not the Abyss!'; } RECOVER { ok 1 => "Recovered"; RESULT { 42 } } ; } my $foo = foo(); ok +($foo?1:0) => 'BOOLEAN'; is "$foo", "42" => 'STRING'; ok $foo == 42 => 'NUM'; Contextual-Return-0.004008/t/RECOVER_RESULT.t000644 000765 000765 00000001133 11176205337 017572 0ustar00damian000000 000000 use Contextual::Return; sub bar { return 'in bar'; } sub foo { return BOOL { 0 } LIST { 1,2,3 } NUM { 42 } STR { 'forty-two' } SCALAR { 86 } RECOVER { RESULT { wantarray ? 1..9 : 99 } } ; } package Other; use Test::More qw< no_plan >; is_deeply [ ::foo() ], [1..9] => 'LIST context'; is do{ ::foo() ? 'true' : 'false' }, 'true' => 'BOOLEAN context'; is 0+::foo(), 99 => 'NUMERIC context'; is "".::foo(), '99' => 'STRING context'; Contextual-Return-0.004008/t/retobj.t000644 000765 000765 00000001132 11705643263 016655 0ustar00damian000000 000000 use Contextual::Return; sub foo { return PUREBOOL { $_ = RETOBJ; next handler; } BOOL { 1 } DEFAULT { 42 } ; } package Other; use Test::More 'no_plan'; is do{ ::foo() ? 'true' : 'false' }, 'true' => 'PURE BOOLEAN context'; is $_, 42 => 'Pure boolean assigned'; is ref $_, 'Contextual::Return::Value' => 'RETOBJ is object'; my $x; undef $_; is do{ ($x = ::foo()) ? 'true' : 'false' }, 'true' => 'BOOLEAN context'; ok !defined $_ => 'RETOBJ not assigned'; Contextual-Return-0.004008/t/scalar-to-list.t000644 000765 000765 00000001537 10324200125 020215 0ustar00damian000000 000000 use Test::More 'no_plan'; use Contextual::Return; sub scalar_only { return ( SCALAR { "scalar" } ); } is join(q{ }, qw(It got a), scalar_only()), "It got a scalar" => 'Fell back to scalar'; sub str_num { return ( STR { "scalar" } NUM { 1 } ); } is join(q{ }, qw(It got a), str_num()), "It got a scalar" => 'Fell back to str'; is join(q{ }, qw(It got a), 0+str_num()), "It got a 1" => 'Fell back to num'; sub num_only { return ( NUM { 1 } ); } is join(q{ }, qw(It got a), num_only()), "It got a 1" => 'Fell back to num'; sub listy { return ( LIST { qw(list of strings) } STR { "scalar" } NUM { 1 } ); } is join(q{ }, qw(It got a), listy()), "It got a list of strings" => 'List not preempted'; Contextual-Return-0.004008/t/SCALAR.t000644 000765 000765 00000000650 10243565132 016333 0ustar00damian000000 000000 use Contextual::Return; use Test::More 'no_plan'; sub foo { return SCALAR { 86 } VALUE { 42, 99 } } is_deeply \@{foo()}, [42,99] => 'ARRAYREF from NONVOID'; is ${foo()}+0, 86 => 'NUMERIC from SCALAR'; is "${foo()}", '86' => 'STRING from SCALAR'; is "@{foo()}", '42 99' => 'STRING from NONVOID'; Contextual-Return-0.004008/t/simple.t000644 000765 000765 00000002331 11304047167 016657 0ustar00damian000000 000000 use Contextual::Return; sub bar { return 'in bar'; } sub foo { return PUREBOOL { 1 } BOOL { 0 } LIST { 1,2,3 } NUM { 42 } STR { 'forty-two' } SCALAR { 86 } SCALARREF { \7 } HASHREF { { name => 'foo', value => 99} } ARRAYREF { [3,2,1] } GLOBREF { \*STDERR } CODEREF { \&bar } ; } package Other; use Test::More 'no_plan'; is_deeply [ ::foo() ], [1,2,3] => 'LIST context'; is do{ ::foo() ? 'true' : 'false' }, 'true' => 'PURE BOOLEAN context'; my $x; is do{ ($x = ::foo()) ? 'true' : 'false' }, 'false' => 'BOOLEAN context'; is 0+::foo(), 42 => 'NUMERIC context'; is "".::foo(), 'forty-two' => 'STRING context'; is ${::foo}, 7 => 'SCALARREF context'; is_deeply \%{::foo()}, { name => 'foo', value => 99} => 'HASHREF context'; is_deeply \@{::foo()}, [3,2,1] => 'ARRAYREF context'; is \*{::foo()}, \*STDERR => 'GLOBREF context'; is ::foo->(), 'in bar' => 'ARRAYREF context'; Contextual-Return-0.004008/t/simple_export.t000644 000765 000765 00000001722 11176177357 020277 0ustar00damian000000 000000 use Contextual::Return qr{BOOL|LIST|NUM}; sub bar { return 'in bar'; } sub foo { return BOOL { 0 } LIST { 1,2,3 } NUM { 42 } ; } package Other; use Test::More 'no_plan'; is_deeply [ ::foo() ], [1,2,3] => 'LIST context'; is do{ ::foo() ? 'true' : 'false' }, 'false' => 'BOOLEAN context'; is 0+::foo(), 42 => 'NUMERIC context'; no warnings 'once'; ok ! *main::STR{CODE} => 'No STRING context'; ok ! *main::SCALAR{CODE} => 'No SCALAR context'; ok ! *main::SCALARREF{CODE} => 'No SCALARREF context'; ok ! *main::HASHREF{CODE} => 'No HASHREF context'; ok ! *main::ARRAYREF{CODE} => 'No ARRAYREF context'; ok ! *main::GLOBREF{CODE} => 'No GLOBREF context'; ok ! *main::CODEREF{CODE} => 'No CODEREF context'; Contextual-Return-0.004008/t/simple_prefix.t000644 000765 000765 00000002214 11176200204 020222 0ustar00damian000000 000000 use Contextual::Return qr{.+} => 'ANTE_%s'; sub bar { return 'in bar'; } sub foo { return ANTE_BOOL { 0 } ANTE_LIST { 1,2,3 } ANTE_NUM { 42 } ANTE_STR { 'forty-two' } ANTE_SCALAR { 86 } ANTE_SCALARREF { \7 } ANTE_HASHREF { { name => 'foo', value => 99} } ANTE_ARRAYREF { [3,2,1] } ANTE_GLOBREF { \*STDERR } ANTE_CODEREF { \&bar } ; } package Other; use Test::More 'no_plan'; is_deeply [ ::foo() ], [1,2,3] => 'LIST context'; is do{ ::foo() ? 'true' : 'false' }, 'false' => 'BOOLEAN context'; is 0+::foo(), 42 => 'NUMERIC context'; is "".::foo(), 'forty-two' => 'STRING context'; is ${::foo}, 7 => 'SCALARREF context'; is_deeply \%{::foo()}, { name => 'foo', value => 99} => 'HASHREF context'; is_deeply \@{::foo()}, [3,2,1] => 'ARRAYREF context'; is \*{::foo()}, \*STDERR => 'GLOBREF context'; is ::foo->(), 'in bar' => 'ARRAYREF context'; Contextual-Return-0.004008/t/simple_rename.t000644 000765 000765 00000002351 11176200102 020173 0ustar00damian000000 000000 use Contextual::Return qr{}, BOOL => BOOLEAN, LIST => VECTOR, NUM => NUMERIC, STR => STRINGIFIC, SCALAR => SINGULAR, ; sub bar { return 'in bar'; } sub foo { return BOOLEAN { 0 } VECTOR { 1,2,3 } NUMERIC { 42 } STRINGIFIC { 'forty-two' } SINGULAR { 86 } SCALARREF { \7 } HASHREF { { name => 'foo', value => 99} } ARRAYREF { [3,2,1] } GLOBREF { \*STDERR } CODEREF { \&bar } ; } package Other; use Test::More 'no_plan'; is_deeply [ ::foo() ], [1,2,3] => 'LIST context'; is do{ ::foo() ? 'true' : 'false' }, 'false' => 'BOOLEAN context'; is 0+::foo(), 42 => 'NUMERIC context'; is "".::foo(), 'forty-two' => 'STRING context'; is ${::foo}, 7 => 'SCALARREF context'; is_deeply \%{::foo()}, { name => 'foo', value => 99} => 'HASHREF context'; is_deeply \@{::foo()}, [3,2,1] => 'ARRAYREF context'; is \*{::foo()}, \*STDERR => 'GLOBREF context'; is ::foo->(), 'in bar' => 'ARRAYREF context'; Contextual-Return-0.004008/t/simple_RESULT.t000644 000765 000765 00000002626 11051044134 017752 0ustar00damian000000 000000 use Contextual::Return; sub bar { return 'in bar'; } sub foo { return BOOL { RESULT { 0 }; undef } LIST { RESULT { 1,2,3 }; undef } NUM { RESULT { 42 }; undef } STR { RESULT { 'forty-two' }; undef } SCALAR { RESULT { 86 }; undef } SCALARREF { RESULT { \7 }; undef } HASHREF { RESULT { { name => 'foo', value => 99} }; undef } ARRAYREF { RESULT { [3,2,1] }; undef } GLOBREF { RESULT { \*STDERR }; undef } CODEREF { RESULT { \&bar }; undef } ; } package Other; use Test::More 'no_plan'; is_deeply [ ::foo() ], [1,2,3] => 'LIST context'; is do{ ::foo() ? 'true' : 'false' }, 'false' => 'BOOLEAN context'; is 0+::foo(), 42 => 'NUMERIC context'; is "".::foo(), 'forty-two' => 'STRING context'; is ${::foo}, 7 => 'SCALARREF context'; is_deeply \%{::foo()}, { name => 'foo', value => 99} => 'HASHREF context'; is_deeply \@{::foo()}, [3,2,1] => 'ARRAYREF context'; is \*{::foo()}, \*STDERR => 'GLOBREF context'; is ::foo->(), 'in bar' => 'ARRAYREF context'; use Contextual::Return; sub bar { NUM { 42 } RECOVER { RESULT { RESULT()+1 } } } is 0+bar(), 43, => 'RESULT()'; Contextual-Return-0.004008/t/STRICT.t000644 000765 000765 00000002701 11741225344 016377 0ustar00damian000000 000000 use Contextual::Return; sub bar { return 'in bar'; } sub foo { return STRICT PUREBOOL { 1 } BOOL { 0 } LIST { 1,2,3 } NUM { 42 } STR { 'forty-two' } REF { [] } DEFAULT { {} } ; } package Other; use Test::More 'no_plan'; is_deeply [ ::foo() ], [1,2,3] => 'LIST context'; is do{ ::foo() ? 'true' : 'false' }, 'true' => 'PURE BOOLEAN context'; is do{ (my $x = ::foo()) ? 'true' : 'false' }, 'false' => 'BOOLEAN context'; is 0+::foo(), 42 => 'NUMERIC context'; is "".::foo(), 'forty-two' => 'STRING context'; ok !eval { ::foo(); 1 } => 'No VOID context'; like $@, qr{Can't call main::foo in a void context} => '...with correct error msg'; ok !eval { my $scalar = ${::foo()}; 1 } => 'No SCALARREF context'; like $@, qr{Call to main::foo didn't return a scalar reference, as required} => '...with correct error msg'; ok !eval { my @list = @{::foo()}; 1 } => 'No ARRAYREF context'; like $@, qr{Call to main::foo didn't return an array reference, as required} => '...with correct error msg'; ok !eval { my %hash = %{::foo()}; 1 } => 'No HASHREF context'; like $@, qr{Call to main::foo didn't return a hash reference, as required} => '...with correct error msg'; Contextual-Return-0.004008/t/try000644 000765 000765 00000000122 11154120276 015732 0ustar00damian000000 000000 use Contextual::Return; sub foo { return FAIL { 'failed' }; } print 1+foo; Contextual-Return-0.004008/lib/Contextual/000755 000765 000765 00000000000 12574714432 017641 5ustar00damian000000 000000 Contextual-Return-0.004008/lib/Contextual/Return/000755 000765 000765 00000000000 12574714432 021120 5ustar00damian000000 000000 Contextual-Return-0.004008/lib/Contextual/Return.pm000644 000765 000765 00000370321 12574714416 021466 0ustar00damian000000 000000 package Contextual::Return; use warnings; use strict; our $VERSION = '0.004008'; my %attrs_of; # This is localized as caller to hide the interim blocks... my $smart_caller; # Fake out Carp::*, and Scalar::Util::blessed() very early... BEGIN { no warnings 'redefine'; my $fallback_caller = *CORE::GLOBAL::caller{CODE}; if (!defined $fallback_caller) { *CORE::GLOBAL::caller = sub (;$) { my ($height) = @_; $height++; my @caller = CORE::caller($height); if ( CORE::caller() eq 'DB' ) { # Oops, redo picking up @DB::args package DB; @caller = CORE::caller($height); } return if ! @caller; # empty return $caller[0] if ! wantarray; # scalar context return @_ ? @caller : @caller[0..2]; # extra info or regular }; } $smart_caller = sub (;$) { my ($uplevels) = $_[0] || 0; my @caller; if (CORE::caller eq 'DB') { package DB; if ($fallback_caller) { @caller = $fallback_caller->($uplevels + 5 + $Contextual::Return::uplevel) if $Contextual::Return::uplevel; @caller = $fallback_caller->($uplevels + 4); } else { @caller = CORE::caller($uplevels + 5 + $Contextual::Return::uplevel) if $Contextual::Return::uplevel; @caller = CORE::caller($uplevels + 4); } } else { if ($fallback_caller) { @caller = $fallback_caller->($uplevels + 5 + $Contextual::Return::uplevel) if $Contextual::Return::uplevel; @caller = $fallback_caller->($uplevels + 4); } else { @caller = CORE::caller($uplevels + 5 + $Contextual::Return::uplevel) if $Contextual::Return::uplevel; @caller = CORE::caller($uplevels + 4); } } return if ! @caller; # empty return $caller[0] if ! wantarray; # scalar context return @_ ? @caller : @caller[0..2]; # extra info or regular }; use Carp; my $real_carp = *Carp::carp{CODE}; my $real_croak = *Carp::croak{CODE}; *Carp::carp = sub { goto &{$real_carp} if !$Contextual::Return::uplevel; warn _in_context(@_); }; *Carp::croak = sub { goto &{$real_croak} if !$Contextual::Return::uplevel; die _in_context(@_); }; # Scalar::Util::blessed()... use Scalar::Util 'refaddr'; # Remember the current blessed()... my $original_blessing = *Scalar::Util::blessed{CODE}; # ...and replace it... *Scalar::Util::blessed = sub($) { no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; # Are we operating on a CRV??? my $attrs = $attrs_of{refaddr $_[0] or q{}}; # If not, use the original code... goto &{$original_blessing} if !$attrs; # Does this object have a BLESSED handler??? if (exists $attrs->{BLESSED}) { return $attrs->{BLESSED}->(@{$attrs->{args}}); } # Otherwise, find the appropriate scalar handler... handler: for my $context (qw( OBJREF LAZY REF SCALAR VALUE NONVOID DEFAULT )) { my $handler = $attrs->{$context} or next handler; my $obj_ref = eval { $handler->(@{$attrs->{args}}) }; my $was_blessed = $original_blessing->($obj_ref); return $was_blessed if $was_blessed; } # Otherwise, simulate unblessed status... return undef; }; } sub _in_context { my $msg = join q{}, @_; # Start looking in caller... my $stack_frame = 1; my ($package, $file, $line, $sub) = CORE::caller($stack_frame++); my ($orig_package, $prev_package) = ($package) x 2; my $LOC = qq{at $file line $line}; # Walk up stack... STACK_FRAME: while (1) { my ($package, $file, $line, $sub) = CORE::caller($stack_frame++); # Fall off the top of the stack... last STACK_FRAME if !defined $package; # Ignore this module (and any helpers)... next STACK_FRAME if $package =~ m{^Contextual::Return}xms; # Track the call up the stack... $LOC = qq{at $file line $line}; # Ignore any @CARP_NOT'ed packages next STACK_FRAME if do { no strict 'refs'; *{$package.'::CARP_NOT'}{ARRAY}; }; # Ignore transitions within original caller... next STACK_FRAME if $package eq $orig_package && $prev_package eq $orig_package; # If we get a transition out of the original package, we're there... last STACK_FRAME; } # Insert location details... $msg =~ s//$LOC/g or $msg =~ s/[^\S\n]*$/ $LOC/; $msg =~ s/$/\n/; return $msg; } # Indentation corresponds to inherited fall-back relationships... my @CONTEXTS = qw( DEFAULT VOID NONVOID LIST SCALAR VALUE STR NUM BOOL PUREBOOL REF SCALARREF ARRAYREF CODEREF HASHREF GLOBREF OBJREF METHOD BLESSED ); my @ALL_EXPORTS = ( @CONTEXTS, qw( LAZY RESULT RVALUE METHOD FAIL FIXED RECOVER LVALUE RETOBJ FAIL_WITH ACTIVE CLEANUP NVALUE STRICT BLESSED ) ); my %STD_NAME_FOR = map { $_ => $_ } @ALL_EXPORTS; sub import { # Load utility module for failure handlers... if (require Contextual::Return::Failure) { *FAIL = \&Contextual::Return::Failure::_FAIL; *FAIL_WITH = \&Contextual::Return::Failure::_FAIL_WITH; } # Don't need the package name... shift @_; # If args, export nothing by default; otherwise export all... my %exports = @_ ? () : %STD_NAME_FOR; # All args are export either selectors and/or renamers... while (my $selector = shift @_) { my $next_arg = $_[0]; my $renamer = (defined $next_arg && !ref $next_arg && !exists $STD_NAME_FOR{$next_arg}) ? shift(@_) : undef; %exports = (%exports, _add_exports_for($selector, $renamer)); } # Loop through possible exports, exporting anything requested... my $caller = CORE::caller; EXPORT: for my $subname (keys %exports) { no strict qw( refs ); *{$caller.'::'.$exports{$subname}} = \&{$subname}; } }; sub _add_exports_for { my ($selector, $renamer) = @_; # If no renamer, use original name... $renamer ||= '%s'; # Handle different types of selector... my $selector_type = ref($selector) || 'literal'; # Array selector recursively export each element... if ($selector_type eq 'ARRAY') { return map { _add_exports_for($_,$renamer) } @{$selector}; } elsif ($selector_type eq 'Regexp') { my @selected = grep {/$selector/} @ALL_EXPORTS; if (!@selected) { Carp::carp("use Contextual::Return $selector didn't export anything"); } return map { $_ => sprintf($renamer, $_) } @selected; } elsif ($selector_type eq 'literal') { Carp::croak "Can't export $selector: no such handler" if !exists $STD_NAME_FOR{$selector}; return ( $selector => sprintf($renamer, $selector) ); } else { Carp::croak "Can't use $selector_type as export specifier"; } } # Let handlers access the result object they're inside... sub RETOBJ() { our $__RETOBJ__; return $__RETOBJ__; } use Scalar::Util qw( refaddr ); # Override return value in a C::R handler... sub RESULT(;&) { my ($block) = @_; # Determine call context and arg list... my $context; my $args = do { package DB; $context=(CORE::caller 1)[5]; \@DB::args }; # No args -> return appropriate value... if (!@_) { return $context ? @{ $Contextual::Return::__RESULT__ || [] } : $Contextual::Return::__RESULT__->[0] ; } # Hide from caller() and the enclosing eval{}... # Evaluate block in context and cache result... local $Contextual::Return::uplevel = $Contextual::Return::uplevel+1; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; $Contextual::Return::__RESULT__ = $context ? [ $block->(@{$args}) ] : defined $context ? [ scalar $block->(@{$args}) ] : do { $block->(@{$args}); [] } ; return; } sub RVALUE(&;@) :lvalue; sub LVALUE(&;@) :lvalue; sub NVALUE(&;@) :lvalue; my %opposite_of = ( 'RVALUE' => 'LVALUE or NVALUE', 'LVALUE' => 'RVALUE or NVALUE', 'NVALUE' => 'LVALUE or RVALUE', ); BEGIN { for my $subname (qw( RVALUE LVALUE NVALUE) ) { no strict 'refs'; *{$subname} = sub(&;@) :lvalue { # (handler, return_lvalue); my $handler = shift; my $impl; my $args = do{ package DB; ()=CORE::caller(1); \@DB::args }; if (@_==0) { $impl = tie $_[0], 'Contextual::Return::Lvalue', $subname => $handler, args=>$args; } elsif (@_==1 and $impl = tied $_[0]) { die _in_context "Can't install two $subname handlers" if exists $impl->{$subname}; $impl->{$subname} = $handler; } else { my $vals = join q{, }, map { tied $_ ? keys %{tied $_} : defined $_ ? $_ : 'undef' } @_; die _in_context "Expected a $opposite_of{$subname} block ", "after the $subname block ", "but found instead: $vals\n"; } # Handle void context calls... if (!defined wantarray && $impl->{NVALUE}) { # Fake out caller() and Carp... local $Contextual::Return::uplevel = 1; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; # Call and clear handler... local $Contextual::Return::__RETOBJ__ = $impl; $impl->{NVALUE}( @{$impl->{args}} ); delete $impl->{NVALUE}; } $_[0]; } } } for my $modifier_name (qw< STRICT FIXED ACTIVE >) { no strict 'refs'; *{$modifier_name} = sub ($) { my ($crv) = @_; my $attrs = $attrs_of{refaddr $crv or q{}}; # Track context... my $wantarray = wantarray; use Want; $attrs->{want_pure_bool} ||= Want::want('BOOL'); # Remember the modification... $attrs->{$modifier_name} = 1; # Prepare for exception handling... my $recover = $attrs->{RECOVER}; local $Contextual::Return::uplevel = 2; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; # Handle list context directly, if possible... if ($wantarray) { local $Contextual::Return::__RESULT__; # List or ancestral handlers... handler: for my $context (qw(LIST VALUE NONVOID DEFAULT)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; my @rv = eval { $handler->(@{$attrs->{args}}) }; if ($recover) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [@rv]; } () = $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } return @rv if !$Contextual::Return::__RESULT__; return @{$Contextual::Return::__RESULT__}; } # Convert to list from arrayref handler... if (!$attrs->{STRICT} and my $handler = $attrs->{ARRAYREF}) { my $array_ref = eval { $handler->(@{$attrs->{args}}) }; if ($recover) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$array_ref]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } # Array ref may be returned directly, or via RESULT{}... $array_ref = $Contextual::Return::__RESULT__->[0] if $Contextual::Return::__RESULT__; return @{$array_ref} if (ref $array_ref||q{}) eq 'ARRAY'; } # Return scalar object as one-elem list, if possible... handler: for my $context (qw(BOOL STR NUM VALUE SCALAR LAZY)) { last handler if $attrs->{STRICT}; return $crv if exists $attrs->{$context}; } $@ = _in_context "Can't call $attrs->{sub} in a list context"; if ($recover) { () = $recover->(@{$attrs->{args}}); } else { die $@; } } # Handle void context directly... if (!defined $wantarray) { handler: for my $context (qw< VOID DEFAULT >) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; eval { $attrs->{$context}->(@{$attrs->{args}}) }; if ($recover) { $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } last handler; } if ($attrs->{STRICT}) { $@ = _in_context "Can't call $attrs->{sub} in a void context"; if ($recover) { () = $recover->(@{$attrs->{args}}); } else { die $@; } } return; } # Otherwise, let someone else handle it... return $crv; } } sub LIST (;&$) { my ($block, $crv) = @_; # Handle simple context tests... return !!(CORE::caller 1)[5] if !@_; # Ensure we have an object... my $attrs; if (!refaddr $crv) { my $args = do{ package DB; ()=CORE::caller(1); \@DB::args }; my $subname = (CORE::caller(1))[3]; if (!defined $subname) { $subname = 'bare LIST {...}'; } $crv = bless \my $scalar, 'Contextual::Return::Value'; $attrs = $attrs_of{refaddr $crv} = { args => $args, sub => $subname }; } else { $attrs = $attrs_of{refaddr $crv}; } local $Contextual::Return::__RETOBJ__ = $crv; # Handle repetitions... die _in_context "Can't install two LIST handlers" if exists $attrs->{LIST}; # Identify contexts... my $wantarray = wantarray; use Want; $attrs->{want_pure_bool} ||= Want::want('BOOL'); # Prepare for exception handling... my $recover = $attrs->{RECOVER}; local $Contextual::Return::uplevel = 2; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; # Handle list context directly... if ($wantarray) { local $Contextual::Return::__RESULT__; my @rv = eval { $block->(@{$attrs->{args}}) }; if ($recover) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [@rv]; } () = $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } return @rv if !$Contextual::Return::__RESULT__; return @{$Contextual::Return::__RESULT__}; } # Handle void context directly... if (!defined $wantarray) { handler: for my $context (qw< VOID DEFAULT >) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; eval { $attrs->{$context}->(@{$attrs->{args}}) }; if ($recover) { $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } last handler; } if ($attrs->{STRICT}) { $@ = _in_context "Can't call $attrs->{sub} in a void context"; if ($recover) { () = $recover->(@{$attrs->{args}}); } else { die $@; } } return; } # Otherwise, cache handler... $attrs->{LIST} = $block; return $crv; } sub VOID (;&$) { my ($block, $crv) = @_; # Handle simple context tests... return !defined( (CORE::caller 1)[5] ) if !@_; # Ensure we have an object... my $attrs; if (!refaddr $crv) { my $args = do{ package DB; ()=CORE::caller(1); \@DB::args }; my $subname = (CORE::caller(1))[3]; if (!defined $subname) { $subname = 'bare VOID {...}'; } $crv = bless \my $scalar, 'Contextual::Return::Value'; $attrs = $attrs_of{refaddr $crv} = { args => $args, sub => $subname }; } else { $attrs = $attrs_of{refaddr $crv}; } local $Contextual::Return::__RETOBJ__ = $crv; # Handle repetitions... die _in_context "Can't install two VOID handlers" if exists $attrs->{VOID}; # Identify contexts... my $wantarray = wantarray; use Want; $attrs->{want_pure_bool} ||= Want::want('BOOL'); # Prepare for exception handling... my $recover = $attrs->{RECOVER}; local $Contextual::Return::uplevel = 2; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; # Handle list context directly, if possible... if ($wantarray) { local $Contextual::Return::__RESULT__; # List or ancestral handlers... handler: for my $context (qw(LIST VALUE NONVOID DEFAULT)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; my @rv = eval { $handler->(@{$attrs->{args}}) }; if ($recover) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [@rv]; } () = $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } return @rv if !$Contextual::Return::__RESULT__; return @{$Contextual::Return::__RESULT__}; } # Convert to list from arrayref handler... if (!$attrs->{STRICT} and my $handler = $attrs->{ARRAYREF}) { my $array_ref = eval { $handler->(@{$attrs->{args}}) }; if ($recover) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$array_ref]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } # Array ref may be returned directly, or via RESULT{}... $array_ref = $Contextual::Return::__RESULT__->[0] if $Contextual::Return::__RESULT__; return @{$array_ref} if (ref $array_ref||q{}) eq 'ARRAY'; } # Return scalar object as one-elem list, if possible... handler: for my $context (qw(BOOL STR NUM VALUE SCALAR LAZY)) { last handler if $attrs->{STRICT}; return $crv if exists $attrs->{$context}; } $@ = _in_context "Can't call $attrs->{sub} in a list context"; if ($recover) { () = $recover->(@{$attrs->{args}}); } else { die $@; } } # Handle void context directly... if (!defined $wantarray) { eval { $block->(@{$attrs->{args}}) }; if ($recover) { $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } return; } # Otherwise, cache handler... $attrs->{VOID} = $block; return $crv; } for my $context (qw( SCALAR NONVOID )) { no strict qw( refs ); *{$context} = sub (;&$) { my ($block, $crv) = @_; # Handle simple context tests... if (!@_) { my $callers_context = (CORE::caller 1)[5]; return defined $callers_context && ($context eq 'NONVOID' || !$callers_context); } # Ensure we have an object... my $attrs; if (!refaddr $crv) { my $args = do{ package DB; ()=CORE::caller(1); \@DB::args }; my $subname = (CORE::caller(1))[3]; if (!defined $subname) { $subname = "bare $context {...}"; } $crv = bless \my $scalar, 'Contextual::Return::Value'; $attrs = $attrs_of{refaddr $crv} = { args => $args, sub => $subname }; } else { $attrs = $attrs_of{refaddr $crv}; } local $Contextual::Return::__RETOBJ__ = $crv; # Make sure this block is a possibility too... die _in_context "Can't install two $context handlers" if exists $attrs->{$context}; $attrs->{$context} = $block; # Identify contexts... my $wantarray = wantarray; use Want (); $attrs->{want_pure_bool} ||= Want::want('BOOL'); # Prepare for exception handling... my $recover = $attrs->{RECOVER}; local $Contextual::Return::uplevel = 2; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; # Handle list context directly, if possible... if ($wantarray) { local $Contextual::Return::__RESULT__; # List or ancestral handlers... handler: for my $context (qw(LIST VALUE NONVOID DEFAULT)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; my @rv = eval { $handler->(@{$attrs->{args}}) }; if ($recover) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [@rv]; } () = $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } return @rv if !$Contextual::Return::__RESULT__; return @{$Contextual::Return::__RESULT__}; } # Convert to list from arrayref handler... if (!$attrs->{STRICT} and my $handler = $attrs->{ARRAYREF}) { my $array_ref = eval { $handler->(@{$attrs->{args}}) }; if ($recover) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$array_ref]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } # Array ref may be returned directly, or via RESULT{}... $array_ref = $Contextual::Return::__RESULT__->[0] if $Contextual::Return::__RESULT__; return @{$array_ref} if (ref $array_ref||q{}) eq 'ARRAY'; } # Return scalar object as one-elem list, if possible... handler: for my $context (qw(BOOL STR NUM VALUE SCALAR LAZY)) { last if $attrs->{STRICT}; return $crv if exists $attrs->{$context}; } die _in_context "Can't call $attrs->{sub} in a list context"; } # Handle void context directly... if (!defined $wantarray) { handler: for my $context (qw< VOID DEFAULT >) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; eval { $handler->(@{$attrs->{args}}) }; if ($recover) { $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } last handler; } if ($attrs->{STRICT}) { $@ = _in_context "Can't call $attrs->{sub} in a void context"; if ($recover) { () = $recover->(@{$attrs->{args}}); } else { die $@; } } return; } # Otherwise, defer evaluation by returning an object... return $crv; } } handler: for my $context_name (@CONTEXTS, qw< RECOVER _internal_LIST CLEANUP >) { next handler if $context_name eq 'LIST' # These || $context_name eq 'VOID' # four || $context_name eq 'SCALAR' # handled || $context_name eq 'NONVOID'; # separately no strict qw( refs ); *{$context_name} = sub (&;$) { my ($block, $crv) = @_; # Ensure we have an object... my $attrs; if (!refaddr $crv) { my $args = do{ package DB; ()=CORE::caller(1); \@DB::args }; my $subname = (CORE::caller(1))[3]; if (!defined $subname) { $subname = "bare $context_name {...}"; } $crv = bless \my $scalar, 'Contextual::Return::Value'; $attrs = $attrs_of{refaddr $crv} = { args => $args, sub => $subname }; } else { $attrs = $attrs_of{refaddr $crv}; } local $Contextual::Return::__RETOBJ__ = $crv; # Make sure this block is a possibility too... if ($context_name ne '_internal_LIST') { die _in_context "Can't install two $context_name handlers" if exists $attrs->{$context_name}; $attrs->{$context_name} = $block; } # Identify contexts... my $wantarray = wantarray; use Want (); $attrs->{want_pure_bool} ||= Want::want('BOOL'); # Prepare for exception handling... my $recover = $attrs->{RECOVER}; local $Contextual::Return::uplevel = 2; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; # Handle list context directly, if possible... if ($wantarray) { local $Contextual::Return::__RESULT__ = $context_name eq 'RECOVER' ? $Contextual::Return::__RESULT__ : undef ; # List or ancestral handlers... handler: for my $context (qw(LIST VALUE NONVOID DEFAULT)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; my @rv = eval { $handler->(@{$attrs->{args}}) }; if ($recover) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [@rv]; } () = $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } return @rv if !$Contextual::Return::__RESULT__; return @{$Contextual::Return::__RESULT__}; } # Convert to list from arrayref handler... if (!$attrs->{STRICT} and my $handler = $attrs->{ARRAYREF}) { local $Contextual::Return::uplevel = 2; # Array ref may be returned directly, or via RESULT{}... my $array_ref = eval { $handler->(@{$attrs->{args}}) }; if ($recover) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$array_ref]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } $array_ref = $Contextual::Return::__RESULT__->[0] if $Contextual::Return::__RESULT__; return @{$array_ref} if (ref $array_ref||q{}) eq 'ARRAY'; } # Return scalar object as one-elem list, if possible... handler: for my $context (qw(BOOL STR NUM VALUE SCALAR LAZY)) { last if $attrs->{STRICT}; return $crv if exists $attrs->{$context}; } $@ = _in_context "Can't call $attrs->{sub} in a list context"; if ($recover) { () = $recover->(@{$attrs->{args}}); } else { die $@; } } # Handle void context directly... if (!defined $wantarray) { handler: for my $context (qw(VOID DEFAULT)) { if (!$attrs->{$context}) { last handler if $attrs->{STRICT}; next handler; } eval { $attrs->{$context}->(@{$attrs->{args}}) }; if ($recover) { $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } last handler; } if ($attrs->{STRICT}) { $@ = _in_context "Can't call $attrs->{sub} in a void context"; if ($recover) { () = $recover->(@{$attrs->{args}}); } else { die $@; } } return; } # Otherwise, defer evaluation by returning an object... return $crv; } } # Alias LAZY to SCALAR... *LAZY = *SCALAR; # Set $Data::Dumper::Freezer to 'Contextual::Return::FREEZE' to be able to # dump contextual return values... my %operator_impl; my $no_handler_message = qr{ ^ Can't [ ] call [ ] .*? [ ] in [ ] [\w]+ [ ] context | ^ [\w:]+ [ ] can't [ ] return [ ] a [ ] \w+ [ ] reference }xms; sub _flag_self_ref_in { my ($data_ref, $obj_ref) = @_; my $type = ref $data_ref; return if !$type; for my $value ( $type eq 'SCALAR' ? ${$data_ref} : @{$data_ref} ) { no warnings 'numeric', 'uninitialized'; if ($value == $obj_ref) { $value = '<<>>'; } } } sub FREEZE { my ($self) = @_; my $attrs_ref = $attrs_of{refaddr $self}; my $args_ref = $attrs_ref->{args}; my @no_handler; # Call appropriate operator handler, defusing and recording exceptions... my $overloaded = sub { my ($context, $op) = @_; # Try the operator... my $retval = eval { $operator_impl{$op}->($self,@{$args_ref}) }; # Detect and report internal exceptions... if (my $exception = $@) { if ($exception =~ $no_handler_message) { push @no_handler, $context; return (); } return { $context => "<<>>" }; } # Detect self-referential overloadings (to avoid infinite recursion)... { no warnings 'numeric', 'uninitialized'; if (ref $retval eq 'REF' && ${$retval} == ${$self}) { return { $context => "<<>>" }; } } # Normal return of contextual value labelled by context... return { $context => $retval }; }; my @values; # Where did this value originate? push @values, { ISA => 'Contextual::Return::Value' }; push @values, { FROM => $attrs_ref->{sub} }; # Does it return a value in void context? if (exists $attrs_ref->{VOID} || exists $attrs_ref->{DEFAULT}) { push @values, { VOID => undef }; } else { push @no_handler, 'VOID'; } # Generate list context value by "pretend" LIST handler... push @values, { LIST => [ _internal_LIST(sub{}, $self) ] }; _flag_self_ref_in($values[-1]{LIST}, $self); # Generate scalar context values by calling appropriate handler... push @values, $overloaded->( STR => q{""} ); push @values, $overloaded->( NUM => '0+' ); push @values, $overloaded->( BOOL => 'bool' ); push @values, $overloaded->( SCALARREF => '${}' ); _flag_self_ref_in($values[-1]{SCALARREF}, $self); push @values, $overloaded->( ARRAYREF => '@{}' ); _flag_self_ref_in($values[-1]{ARRAYREF}, $self); push @values, $overloaded->( CODEREF => '&{}' ); push @values, $overloaded->( HASHREF => '%{}' ); push @values, $overloaded->( GLOBREF => '*{}' ); # Are there handlers for various "generic" super-contexts... my @fallbacks = grep { $attrs_ref->{$_} } qw< DEFAULT NONVOID SCALAR VALUE REF RECOVER >; push @values, { NO_HANDLER => \@no_handler }; push @values, { FALLBACKS => \@fallbacks }; # Temporarily replace object being dumped, by values found... $_[0] = \@values; } # Call this method on a contextual return value object to debug it... sub DUMP { if (require Data::Dumper) { my ($crv) = @_; FREEZE($crv); return Data::Dumper::Dumper($crv); } else { Carp::carp("Can't DUMP contextual return value (no Data::Dumper!)"); return; } } package Contextual::Return::Value; BEGIN { *_in_context = *Contextual::Return::_in_context; } use Scalar::Util qw( refaddr ); BEGIN { %operator_impl = ( q{""} => sub { my ($self) = @_; local $Contextual::Return::__RETOBJ__ = $self; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; my $attrs = $attrs_of{refaddr $self}; handler: for my $context (qw(STR SCALAR LAZY VALUE NONVOID DEFAULT NUM)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; local $Contextual::Return::__RESULT__; local $Contextual::Return::uplevel = 2; my $rv = eval { $handler->(@{$attrs->{args}}) }; if (my $recover = $attrs->{RECOVER}) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$rv]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } if ($Contextual::Return::__RESULT__) { $rv = $Contextual::Return::__RESULT__->[0]; } if ( $attrs->{FIXED} ) { $_[0] = $rv; } elsif ( !$attrs->{ACTIVE} ) { $attrs->{$context} = sub { $rv }; } return $rv; } $@ = _in_context "Can't use return value of $attrs->{sub} as a string"; if (my $recover = $attrs->{RECOVER}) { scalar $recover->(@{$attrs->{args}}); } else { die $@; } }, q{0+} => sub { my ($self) = @_; local $Contextual::Return::__RETOBJ__ = $self; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; my $attrs = $attrs_of{refaddr $self}; handler: for my $context (qw(NUM SCALAR LAZY VALUE NONVOID DEFAULT STR)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; local $Contextual::Return::__RESULT__; local $Contextual::Return::uplevel = 2; my $rv = eval { $handler->(@{$attrs->{args}}) }; if (my $recover = $attrs->{RECOVER}) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$rv]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } if ($Contextual::Return::__RESULT__) { $rv = $Contextual::Return::__RESULT__->[0]; } if ( $attrs->{FIXED} ) { $_[0] = $rv; } elsif ( !$attrs->{ACTIVE} ) { $attrs->{$context} = sub { $rv }; } return $rv; } $@ = _in_context "Can't use return value of $attrs->{sub} as a number"; if (my $recover = $attrs->{RECOVER}) { scalar $recover->(@{$attrs->{args}}); } else { die $@; } }, q{bool} => sub { my ($self) = @_; local $Contextual::Return::__RETOBJ__ = $self; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; my $attrs = $attrs_of{refaddr $self}; # Handle Calls in Pure Boolean context... my @PUREBOOL = $attrs->{want_pure_bool} ? ('PUREBOOL') : (); $attrs->{want_pure_bool} = 0; handler: for my $context (@PUREBOOL, qw(BOOL STR NUM SCALAR LAZY VALUE NONVOID DEFAULT)) { my $handler = $attrs->{$context} or $context eq 'BOOL' and $attrs->{STRICT} and last handler or next handler; local $Contextual::Return::__RESULT__; local $Contextual::Return::uplevel = 2; my $outer_sig_warn = $SIG{__WARN__}; local $SIG{__WARN__} = sub{ return if $_[0] =~ /^Exiting \S+ via next/; goto &{$outer_sig_warn} if $outer_sig_warn; warn @_; }; my $rv = eval { $handler->(@{$attrs->{args}}) }; if (my $recover = $attrs->{RECOVER}) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$rv]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } if ($Contextual::Return::__RESULT__) { $rv = $Contextual::Return::__RESULT__->[0]; } if ( $attrs->{FIXED} ) { $_[0] = $rv; } elsif ( !$attrs->{ACTIVE} ) { $attrs->{$context} = sub { $rv }; } return $rv; } $@ = _in_context "Can't use return value of $attrs->{sub} as a boolean"; if (my $recover = $attrs->{RECOVER}) { scalar $recover->(@{$attrs->{args}}); } else { die $@; } }, '${}' => sub { my ($self) = @_; local $Contextual::Return::__RETOBJ__ = $self; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; my $attrs = $attrs_of{refaddr $self}; handler: for my $context (qw(SCALARREF REF NONVOID DEFAULT)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; local $Contextual::Return::__RESULT__; local $Contextual::Return::uplevel = 2; my $rv = eval { $handler->(@{$attrs->{args}}) }; if (my $recover = $attrs->{RECOVER}) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$rv]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } if ($Contextual::Return::__RESULT__) { $rv = $Contextual::Return::__RESULT__->[0]; } # Catch bad behaviour... die _in_context "$context block did not return ", "a suitable reference to the scalar dereference" if ref($rv) ne 'SCALAR' && ref($rv) ne 'OBJ'; if ( $attrs->{FIXED} ) { $_[0] = $rv; } elsif ( !$attrs->{ACTIVE} ) { $attrs->{$context} = sub { $rv }; } return $rv; } if ($attrs->{STRICT}) { $@ = _in_context "Call to $attrs->{sub} didn't return a scalar reference, as required "; if (my $recover = $attrs->{RECOVER}) { scalar $recover->(@{$attrs->{args}}); } else { die $@; } } if ( $attrs->{FIXED} ) { $_[0] = \$self; } return \$self; }, '@{}' => sub { my ($self) = @_; local $Contextual::Return::__RETOBJ__ = $self; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; my $attrs = $attrs_of{refaddr $self}; local $Contextual::Return::__RESULT__; handler: for my $context (qw(ARRAYREF REF)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; local $Contextual::Return::uplevel = 2; my $rv = eval { $handler->(@{$attrs->{args}}) }; if (my $recover = $attrs->{RECOVER}) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$rv]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } if ($Contextual::Return::__RESULT__) { $rv = $Contextual::Return::__RESULT__->[0]; } # Catch bad behaviour... die _in_context "$context block did not return ", "a suitable reference to the array dereference" if ref($rv) ne 'ARRAY' && ref($rv) ne 'OBJ'; if ( $attrs->{FIXED} ) { $_[0] = $rv; } elsif ( !$attrs->{ACTIVE} ) { $attrs->{$context} = sub { $rv }; } return $rv; } handler: for my $context (qw(LIST VALUE NONVOID DEFAULT)) { last handler if $attrs->{STRICT}; my $handler = $attrs->{$context} or next handler; local $Contextual::Return::uplevel = 2; my @rv = eval { $handler->(@{$attrs->{args}}) }; if (my $recover = $attrs->{RECOVER}) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [@rv]; } () = $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } if ($Contextual::Return::__RESULT__) { @rv = @{$Contextual::Return::__RESULT__->[0]}; } if ( $attrs->{FIXED} ) { $_[0] = \@rv; } elsif ( !$attrs->{ACTIVE} ) { $attrs->{$context} = sub { @rv }; } return \@rv; } if ($attrs->{STRICT}) { $@ = _in_context "Call to $attrs->{sub} didn't return an array reference, as required "; if (my $recover = $attrs->{RECOVER}) { scalar $recover->(@{$attrs->{args}}); } else { die $@; } } return [ $self ]; }, '%{}' => sub { my ($self) = @_; local $Contextual::Return::__RETOBJ__ = $self; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; my $attrs = $attrs_of{refaddr $self}; handler: for my $context (qw(HASHREF REF NONVOID DEFAULT)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; local $Contextual::Return::__RESULT__; local $Contextual::Return::uplevel = 2; my $rv = eval { $handler->(@{$attrs->{args}}) }; if (my $recover = $attrs->{RECOVER}) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$rv]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } if ($Contextual::Return::__RESULT__) { $rv = $Contextual::Return::__RESULT__->[0]; } # Catch bad behaviour... die _in_context "$context block did not return ", "a suitable reference to the hash dereference" if ref($rv) ne 'HASH' && ref($rv) ne 'OBJ'; if ( $attrs->{FIXED} ) { $_[0] = $rv; } elsif ( !$attrs->{ACTIVE} ) { $attrs->{$context} = sub { $rv }; } return $rv; } $@ = _in_context "Call to $attrs->{sub} didn't return a hash reference, as required "; if (my $recover = $attrs->{RECOVER}) { scalar $recover->(@{$attrs->{args}}); } else { die $@; } }, '&{}' => sub { my ($self) = @_; local $Contextual::Return::__RETOBJ__ = $self; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; my $attrs = $attrs_of{refaddr $self}; handler: for my $context (qw(CODEREF REF NONVOID DEFAULT)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; local $Contextual::Return::__RESULT__; local $Contextual::Return::uplevel = 2; my $rv = eval { $handler->(@{$attrs->{args}}) }; if (my $recover = $attrs->{RECOVER}) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$rv]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } if ($Contextual::Return::__RESULT__) { $rv = $Contextual::Return::__RESULT__->[0]; } # Catch bad behaviour... die _in_context "$context block did not return ", "a suitable reference to the subroutine dereference" if ref($rv) ne 'CODE' && ref($rv) ne 'OBJ'; if ( $attrs->{FIXED} ) { $_[0] = $rv; } elsif ( !$attrs->{ACTIVE} ) { $attrs->{$context} = sub { $rv }; } return $rv; } $@ = _in_context "Call to $attrs->{sub} didn't return a subroutine reference, as required "; if (my $recover = $attrs->{RECOVER}) { scalar $recover->(@{$attrs->{args}}); } else { die $@; } }, '*{}' => sub { my ($self) = @_; local $Contextual::Return::__RETOBJ__ = $self; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; my $attrs = $attrs_of{refaddr $self}; handler: for my $context (qw(GLOBREF REF NONVOID DEFAULT)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; local $Contextual::Return::__RESULT__; local $Contextual::Return::uplevel = 2; my $rv = eval { $handler->(@{$attrs->{args}}) }; if (my $recover = $attrs->{RECOVER}) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$rv]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } if ($Contextual::Return::__RESULT__) { $rv = $Contextual::Return::__RESULT__->[0]; } # Catch bad behaviour... die _in_context "$context block did not return ", "a suitable reference to the typeglob dereference" if ref($rv) ne 'GLOB' && ref($rv) ne 'OBJ'; if ( $attrs->{FIXED} ) { $_[0] = $rv; } elsif ( !$attrs->{ACTIVE} ) { $attrs->{$context} = sub { $rv }; } return $rv; } $@ = _in_context "Call to $attrs->{sub} didn't return a typeglob reference, as required "; if (my $recover = $attrs->{RECOVER}) { scalar $recover->(@{$attrs->{args}}); } else { die $@; } }, ); } use overload %operator_impl, fallback => 1; sub DESTROY { my ($id) = refaddr shift; my $attrs = $attrs_of{$id}; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; if (my $handler = $attrs->{CLEANUP}) { $handler->(@{ $attrs->{args} }); } delete $attrs_of{$id}; return; } my $NO_SUCH_METHOD = qr/\ACan't (?:locate|call)(?: class| object)? method/ms; # Forward metainformation requests to actual class... sub can { my ($invocant) = @_; # Only forward requests on actual C::R::V objects... if (ref $invocant) { our $AUTOLOAD = 'can'; goto &AUTOLOAD; } # Refer requests on classes to actual class hierarchy... return $invocant->SUPER::can(@_[1..$#_]); } sub isa { # Only forward requests on actual C::R::V objects... my ($invocant) = @_; if (ref $invocant) { our $AUTOLOAD = 'isa'; goto &AUTOLOAD; } # Refer requests on classes to actual class hierarchy... return $invocant->SUPER::isa(@_[1..$#_]); } sub AUTOLOAD { my ($self) = @_; our $AUTOLOAD; my ($requested_method) = $AUTOLOAD =~ m{ .* :: (.*) }xms ? $1 : $AUTOLOAD; my $attrs = $attrs_of{refaddr $self} || {}; local $Contextual::Return::__RETOBJ__ = $self; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; # First, see if there is a method call handler... if (my $context_handler = $attrs->{METHOD}) { local $Contextual::Return::__RESULT__; local $Contextual::Return::uplevel = 2; my @method_handlers = eval { $context_handler->(@{$attrs->{args}}) }; if (my $recover = $attrs->{RECOVER}) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [\@method_handlers]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } if ($Contextual::Return::__RESULT__) { @method_handlers = @{$Contextual::Return::__RESULT__}; } # Locate the correct method handler (if any)... MATCHER: while (my ($matcher, $method_handler) = splice @method_handlers, 0, 2) { if (ref($matcher) eq 'ARRAY') { next MATCHER if !grep { $requested_method =~ $_ } @{$matcher}; } elsif ($requested_method !~ $matcher) { next MATCHER; } shift; if (wantarray) { my @result = eval { local $_ = $requested_method; $method_handler->($self,@_); }; die _in_context $@ if $@; return @result; } else { my $result = eval { local $_ = $requested_method; $method_handler->($self,@_); }; die _in_context $@ if $@; return $result; } } } # Next, try to create an object on which to call the method... handler: for my $context (qw(OBJREF STR SCALAR LAZY VALUE NONVOID DEFAULT)) { my $handler = $attrs->{$context} or $attrs->{STRICT} and last handler or next handler; local $Contextual::Return::__RESULT__; local $Contextual::Return::uplevel = 2; my $object = eval { $handler->(@{$attrs->{args}}) }; if (my $recover = $attrs->{RECOVER}) { if (!$Contextual::Return::__RESULT__) { $Contextual::Return::__RESULT__ = [$object]; } scalar $recover->(@{$attrs->{args}}); } elsif ($@) { die $@; } if ($Contextual::Return::__RESULT__) { $object = $Contextual::Return::__RESULT__->[0]; } if ( $attrs->{FIXED} ) { $_[0] = $object; } elsif ( !$attrs->{ACTIVE} ) { $attrs->{$context} = sub { $object }; } shift; if (wantarray) { my @result = eval { $object->$requested_method(@_) }; my $exception = $@; return @result if !$exception; die _in_context $exception if $exception !~ $NO_SUCH_METHOD; } else { my $result = eval { $object->$requested_method(@_) }; my $exception = $@; return $result if !$exception; die _in_context $exception if $exception !~ $NO_SUCH_METHOD; } $@ = _in_context "Can't call method '$requested_method' on $context value returned by $attrs->{sub}"; if (my $recover = $attrs->{RECOVER}) { scalar $recover->(@{$attrs->{args}}); } else { die $@; } } # Otherwise, the method cannot be called, so react accordingly... $@ = _in_context "Can't call method '$requested_method' on value returned by $attrs->{sub}"; if (my $recover = $attrs->{RECOVER}) { return scalar $recover->(@{$attrs->{args}}); } else { die $@; } } package Contextual::Return::Lvalue; sub TIESCALAR { my ($package, @handler) = @_; return bless {@handler}, $package; } # Handle calls that are lvalues... sub STORE { local *CALLER::_ = \$_; local *_ = \$_[1]; local $Contextual::Return::uplevel = 1; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; local $Contextual::Return::__RESULT__; my $rv = $_[0]{LVALUE}( @{$_[0]{args}} ); return $rv if !$Contextual::Return::__RESULT__; return $Contextual::Return::__RESULT__->[0]; } # Handle calls that are rvalues... sub FETCH { local $Contextual::Return::uplevel = 1; no warnings 'redefine'; local *CORE::GLOBAL::caller = $smart_caller; local $Contextual::Return::__RESULT__; my $rv = $_[0]{RVALUE} ? $_[0]{RVALUE}( @{$_[0]{args}} ) : undef; return $rv if !$Contextual::Return::__RESULT__; return $Contextual::Return::__RESULT__->[0]; } sub DESTROY {}; 1; # Magic true value required at end of module __END__ =head1 NAME Contextual::Return - Create context-sensitive return values =head1 VERSION This document describes Contextual::Return version 0.004008 =head1 SYNOPSIS use Contextual::Return; use Carp; sub foo { return SCALAR { 'thirty-twelve' } LIST { 1,2,3 } BOOL { 1 } NUM { 7*6 } STR { 'forty-two' } HASHREF { {name => 'foo', value => 99} } ARRAYREF { [3,2,1] } GLOBREF { \*STDOUT } CODEREF { croak "Don't use this result as code!"; } ; } # and later... if (my $foo = foo()) { for my $count (1..$foo) { print "$count: $foo is:\n" . " array: @{$foo}\n" . " hash: $foo->{name} => $foo->{value}\n" ; } print {$foo} $foo->(); } =head1 DESCRIPTION Usually, when you need to create a subroutine that returns different values in different contexts (list, scalar, or void), you write something like: sub get_server_status { my ($server_ID) = @_; # Acquire server data somehow... my %server_data = _ascertain_server_status($server_ID); # Return different components of that data, # depending on call context... if (wantarray()) { return @server_data{ qw(name uptime load users) }; } if (defined wantarray()) { return $server_data{load}; } if (!defined wantarray()) { carp 'Useless use of get_server_status() in void context'; return; } else { croak q{Bad context! No biscuit!}; } } That works okay, but the code could certainly be more readable. In its simplest usage, this module makes that code more readable by providing three subroutines--C, C, C--that are true only when the current subroutine is called in the corresponding context: use Contextual::Return; sub get_server_status { my ($server_ID) = @_; # Acquire server data somehow... my %server_data = _ascertain_server_status($server_ID); # Return different components of that data # depending on call context... if (LIST) { return @server_data{ qw(name uptime load users) } } if (SCALAR) { return $server_data{load} } if (VOID) { print "$server_data{load}\n" } else { croak q{Bad context! No biscuit!} } } =head2 Contextual returns Those three subroutines can also be used in another way: as labels on a series of I (collectively known as a I). When a context sequence is returned, it automatically selects the appropriate contextual return block for the calling context. So the previous example could be written even more cleanly as: use Contextual::Return; sub get_server_status { my ($server_ID) = @_; # Acquire server data somehow... my %server_data = _ascertain_server_status($server_ID); # Return different components of that data # depending on call context... return ( LIST { return @server_data{ qw(name uptime load users) } } SCALAR { return $server_data{load} } VOID { print "$server_data{load}\n" } DEFAULT { croak q{Bad context! No biscuit!} } ); } The context sequence automatically selects the appropriate block for each call context. =head2 Lazy contextual return values C and C blocks are always executed during the C statement. However, scalar return blocks (C, C, C, C, etc.) blocks are not. Instead, returning any of scalar block types causes the subroutine to return an object that lazily evaluates that block only when the return value is used. This means that returning a C block is a convenient way to implement a subroutine with a lazy return value. For example: sub digest { return SCALAR { my ($text) = @_; md5($text); } } my $digest = digest($text); print $digest; # md5() called only when $digest used as string To better document this usage, the C block has a synonym: C. sub digest { return LAZY { my ($text) = @_; md5($text); } } =head2 Active contextual return values Once a return value has been lazily evaluated in a given context, the resulting value is cached, and thereafter reused in that same context. However, you can specify that, rather than being cached, the value should be re-evaluated I time the value is used: sub make_counter { my $counter = 0; return ACTIVE SCALAR { ++$counter } ARRAYREF { [1..$counter] } } my $idx = make_counter(); print "$idx\n"; # 1 print "$idx\n"; # 2 print "[@$idx]\n"; # [1 2] print "$idx\n"; # 3 print "[@$idx]\n"; # [1 2 3] =head2 Semi-lazy contextual return values Sometimes, single or repeated lazy evaluation of a scalar return value in different contexts isn't what you really want. Sometimes what you really want is for the return value to be lazily evaluated once only (the first time it's used in any context), and then for that first value to be reused whenever the return value is subsequently reevaluated in any other context. To get that behaviour, you can use the C modifier, which causes the return value to morph itself into the actual value the first time it is used. For example: sub lazy { return SCALAR { 42 } ARRAYREF { [ 1, 2, 3 ] } ; } my $lazy = lazy(); print $lazy + 1; # 43 print "@{$lazy}"; # 1 2 3 sub semilazy { return FIXED SCALAR { 42 } ARRAYREF { [ 1, 2, 3 ] } ; } my $semi = semilazy(); print $semi + 1; # 43 print "@{$semi}"; # die q{Can't use string ("42") as an ARRAY ref} =head2 Finer distinctions of scalar context Because the scalar values returned from a context sequence are lazily evaluated, it becomes possible to be more specific about I of scalar value should be returned: a boolean, a number, or a string. To support those distinctions, Contextual::Return provides four extra context blocks: C, C, C, and C: sub get_server_status { my ($server_ID) = @_; # Acquire server data somehow... my %server_data = _ascertain_server_status($server_ID); # Return different components of that data # depending on call context... return ( LIST { @server_data{ qw(name uptime load users) } } PUREBOOL { $_ = $server_data{uptime}; $server_data{uptime} > 0 } BOOL { $server_data{uptime} > 0 } NUM { $server_data{load} } STR { "$server_data{name}: $server_data{uptime}" } VOID { print "$server_data{load}\n" } DEFAULT { croak q{Bad context! No biscuit!} } ); } With these in place, the object returned from a scalar-context call to C now behaves differently, depending on how it's used. For example: if ( my $status = get_server_status() ) { # BOOL: True if uptime > 0 $load_distribution[$status]++; # INT: Evaluates to load value print "$status\n"; # STR: Prints "name: uptime" } if (get_server_status()) { # PUREBOOL: also sets $_; print; # ...which is then used here } =head3 Boolean vs Pure Boolean contexts There is a special subset of boolean contexts where the return value is being used and immediately thrown away. For example, in the loop: while (get_data()) { ... } the value returned by C is tested for truth and then discarded. This is known as "pure boolean context". In contrast, in the loop: while (my $data = get_data()) { ... } the value returned by C is first assigned to C<$data>, then tested for truth. Because of the assignment, the return value is I discarded after the boolean test. This is ordinary "boolean context". In Perl, pure boolean context is often associated with a special side-effect, that does not occur in regular boolean contexts. For example: while (<>) {...} # $_ set as side-effect of pure boolean context while ($v = <>) {...} # $_ NOT set in ordinary boolean context Contextual::Return supports this with a special subcase of C named . In pure boolean contexts, Contextual::Return will call a C handler if one has been defined, or fall back to a C or C handler if no C handler exists. In ordinary boolean contexts only the C or C handlers are tried, even if a C handler is also defined. Typically C handlers are set up to have some side-effect (most commonly: setting C<$_> or <$@>), like so: sub get_data { my ($succeeded, @data) = _go_and_get_data(); return PUREBOOL { $_ = $data[0]; $succeeded; } BOOL { $succeeded; } SCALAR { $data[0]; } LIST { @data; } } However, there is no requirement that they have side-effects. For example, they can also be used to implement "look-but-don't-retrieve-yet" checking: sub get_data { my $data; return PUREBOOL { _check_for_but_dont_get_data(); } BOOL { defined( $data ||= _go_and_get_data() ); } REF { $data ||= _go_and_get_data(); } } =head2 Self-reference within handlers Any handler can refer to the contextual return object it is part of, by calling the C function. This is particularly useful for C and C handlers. For example: return PUREBOOL { $_ = RETOBJ; next handler; } BOOL { !$failed; } DEFAULT { $data; }; =head2 Referential contexts The other major kind of scalar return value is a reference. Contextual::Return provides contextual return blocks that allow you to specify what to (lazily) return when the return value of a subroutine is used as a reference to a scalar (C), to an array (C), to a hash (C), to a subroutine (C), or to a typeglob (C). For example, the server status subroutine shown earlier could be extended to allow it to return a hash reference, thereby supporting "named return values": sub get_server_status { my ($server_ID) = @_; # Acquire server data somehow... my %server_data = _ascertain_server_status($server_ID); # Return different components of that data # depending on call context... return ( LIST { @server_data{ qw(name uptime load users) } } BOOL { $server_data{uptime} > 0 } NUM { $server_data{load} } STR { "$server_data{name}: $server_data{uptime}" } VOID { print "$server_data{load}\n" } HASHREF { return \%server_data } DEFAULT { croak q{Bad context! No biscuit!} } ); } # and later... my $users = get_server_status->{users}; # or, lazily... my $server = get_server_status(); print "$server->{name} load = $server->{load}\n"; =head2 Interpolative referential contexts The C and C context blocks are especially useful when you need to interpolate a subroutine into strings. For example, if you have a subroutine like: sub get_todo_tasks { return ( SCALAR { scalar @todo_list } # How many? LIST { @todo_list } # What are they? ); } # and later... print "There are ", scalar(get_todo_tasks()), " tasks:\n", get_todo_tasks(); then you could make it much easier to interpolate calls to that subroutine by adding: sub get_todo_tasks { return ( SCALAR { scalar @todo_list } # How many? LIST { @todo_list } # What are they? SCALARREF { \scalar @todo_list } # Ref to how many ARRAYREF { \@todo_list } # Ref to them ); } # and then... print "There are ${get_todo_tasks()} tasks:\n@{get_todo_tasks()}"; In fact, this behaviour is so useful that it's the default. If you don't provide an explicit C block, Contextual::Return automatically provides an implicit one that simply returns a reference to whatever would have been returned in scalar context. Likewise, if no C block is specified, the module supplies one that returns the list-context return value wrapped up in an array reference. So you could just write: sub get_todo_tasks { return ( SCALAR { scalar @todo_list } # How many? LIST { @todo_list } # What are they? ); } # and still do this... print "There are ${get_todo_tasks()} tasks:\n@{get_todo_tasks()}"; =head2 Fallback contexts As the previous sections imply, the C, C, C, and various C<*REF {...}> blocks, are special cases of the general C context block. If a subroutine is called in one of these specialized contexts but does not use the corresponding context block, then the more general C block is used instead (if it has been specified). So, for example: sub read_value_from { my ($fh) = @_; my $value = <$fh>; chomp $value; return ( BOOL { defined $value } SCALAR { $value } ); } ensures that the C subroutine returns true in boolean contexts if the read was successful. But, because no specific C or C return behaviours were specified, the subroutine falls back on using its generic C block in all other scalar contexts. Another way to think about this behaviour is that the various kinds of scalar context blocks form a hierarchy: SCALAR ^ | |--< BOOL | |--< NUM | `--< STR Contextual::Return uses this hierarchical relationship to choose the most specific context block available to handle any particular return context, working its way up the tree from the specific type it needs, to the more general type, if that's all that is available. There are two slight complications to this picture. The first is that Perl treats strings and numbers as interconvertable so the diagram (and the Contextual::Return module) also has to allow these interconversions as a fallback strategy: SCALAR ^ | |--< BOOL | |--< NUM | : ^ | v : `--< STR The dotted lines are meant to indicate that this intraconversion is secondary to the main hierarchical fallback. That is, in a numeric context, a C block will only be used if there is no C block I no C block. In other words, the generic context type is always used in preference to string<->number conversion. The second slight complication is that the above diagram only shows a small part of the complete hierarchy of contexts supported by Contextual::Return. The full fallback hierarchy (including dotted interconversions) is: DEFAULT ^ | |--< VOID | `--< NONVOID ^ | |--< VALUE <............... | ^ : | | : | |--< SCALAR <.......:... | | ^ : | | | : | | |--< BOOL : | | | ^ : | | | | : | | | PUREBOOL : | | | : | | |--< NUM <..:. | | | : ^ : | | | v : : | | `--< STR <....:.. | | : | | :: | `--< LIST ................: : | : ^ : | : : : `--- REF : : : ^ : : : | v : : |--< ARRAYREF : | : |--< SCALARREF .............: | |--< HASHREF | |--< CODEREF | |--< GLOBREF | `--< OBJREF <....... METHOD ^ :........... BLESSED As before, each dashed arrow represents a fallback relationship. That is, if the required context specifier isn't available, the arrows are followed until a more generic one is found. The dotted arrows again represent the interconversion of return values, which is attempted only after the normal hierarchical fallback fails. For example, if a subroutine is called in a context that expects a scalar reference, but no C block is provided, then Contextual::Return tries the following blocks in order: REF {...} NONVOID {...} DEFAULT {...} STR {...} (automatically taking a reference to the result) NUM {...} (automatically taking a reference to the result) SCALAR {...} (automatically taking a reference to the result) VALUE {...} (automatically taking a reference to the result) Likewise, in a list context, if there is no C context block, the module tries: VALUE {...} NONVOID {...} DEFAULT {...} ARRAYREF {...} (automatically dereferencing the result) STR {...} (treating it as a list of one element) NUM {...} (treating it as a list of one element) SCALAR {...} (treating it as a list of one element) The more generic context blocks are especially useful for intercepting unexpected and undesirable call contexts. For example, to turn I the automatic scalar-ref and array-ref interpolative behaviour described in L, you could intercept I referential contexts using a generic C context block: sub get_todo_tasks { return ( SCALAR { scalar @todo_list } # How many? LIST { @todo_list } # What are they? REF { croak q{get_todo_task() can't be used as a reference} } ); } print 'There are ', get_todo_tasks(), '...'; # Still okay print "There are ${get_todo_tasks()}..."; # Throws an exception =head2 Treating return values as objects Normally, when a return value is treated as an object (i.e. has a method called on it), Contextual::Return invokes any C handler that was specified in the contextual return list, and delegates the method call to the object returned by that handler. However, you can also be more specific, by specifying a C context handler in the contextual return list. The block of this handler is expected to return one or more method-name/method-handler pairs, like so: return METHOD { get_count => sub { my $n = shift; $data[$n]{count} }, get_items => sub { my $n = shift; $data[$n]{items} }, clear => sub { @data = (); }, reset => sub { @data = (); }, } Then, whenever one of the specified methods is called on the return value, the corresponding subroutine will be called to implement it. The method handlers must always be subroutine references, but the method-name specifiers may be strings (as in the previous example) or they may be specified generically, as either regexes or array references. Generic method names are used to call the same handler for two or more distinct method names. For example, the previous example could be simplified to: return METHOD { qr/get_(\w+)/ => sub { my $n = shift; $data[$n]{$1} }, ['clear','reset'] => sub { @data = (); }, } A method name specified by regex will invoke the corresponding handler for any method call request that the regex matches. A method name specified by array ref will invoke the corresponding handler if the method requested matches any of the elements of the array (which may themselves be strings or regexes). When the method handler is invoked, the name of the method requested is passed to the handler in C<$_>, and the method's argument list is passed (as usual) via C<@_>. Note that any methods not explicitly handled by the C handlers will still be delegated to the object returned by the C handler (if it is also specified). =head2 Not treating return values as objects The use of C and C are slightly complicated by the fact that contextual return values are themselves objects. For example, prior to version 0.4.4 of the module, if you passed a contextual return value to C, it always returned a true value (namely, the string: 'Contextual::Return::Value'), even if the return value had not specified handlers for C or C. In other words, the I of contextual return values (as objects) was getting in the way of the I of contextual return values (as non-objects). So the module now also provides a C handler, which allows you to explicitly control how contextual return values interact with C. If C<$crv> is a contextual return value, by default C will now only return true if that return value has a C, C, C, C, C, C, or C handler that in turn returns a blessed object. However if C<$crv> also provides a C handler, C will return whatever that handler returns. This means: sub simulate_non_object { return BOOL { 1 } NUM { 42 } } sub simulate_real_object { return OBJREF { bless {}, 'My::Class' } BOOL { 1 } NUM { 42 } } sub simulate_faked_object { return BLESSED { 'Foo' } BOOL { 1 } NUM { 42 } } sub simulate_previous_behaviour { return BLESSED { 'Contextual::Return::Value' } BOOL { 1 } NUM { 42 } } say blessed( simulate_non_object() ); # undef say blessed( simulate_real_object() ); # My::Class say blessed( simulate_faked_object() ); # Foo say blessed( simulate_previous_behaviour() ); # Contextual::Return::Value Typically, you either want no C handler (in which case contextual return values pretend not to be blessed objects), or you want C for backwards compatibility with pre-v0.4.7 behaviour. =head3 Preventing fallbacks Sometimes fallbacks can be too helpful. Or sometimes you want to impose strict type checking on a return value. Contextual::Returns allows that via the C specifier. If you include C anywhere in your return statement, the module disables all fallbacks and will therefore through an exception if the return value is used in any way not explicitly specified in the contextual return sequence. For example, to create a subroutine that returns only a string: sub get_name { return STRICT STR { 'Bruce' } } If the return value of the subroutine is used in any other way than as a string, an exception will be thrown. You can still specify handlers for more than a single kind of context when using C: sub get_name { return STRICT STR { 'Bruce' } BOOL { 0 } } ...but these will still be the only contexts in which the return value can be used: my $n = get_name() ? 1 : 2; # Okay because BOOL handler specified my $n = 'Dr' . get_name(); # Okay because STR handler specified my $n = 1 + get_name(); # Exception thrown because no NUM handler In other words, C allows you to impose strict type checking on your contextual return value. =head2 Deferring handlers Because the various handlers form a hierarchy, it's possible to implement more specific handlers by falling back on ("deferring to") more general ones. For example, L handler|"Boolean vs Pure Boolean contexts"> is almost always identical in its basic behaviour to the corresponding C handler, except that it adds some side-effect. For example: return PUREBOOL { $_ = $return_val; defined $return_val && $return_val > 0 } BOOL { defined $return_val && $return_val > 0 } SCALAR { $return_val; } So Contextual::Return allows you to have a handler perform some action and then defer to a more general handler to supply the actual return value. To fall back to a more general case in this way, you simply write: next handler; at the end of the handler in question, after which Contextual::Return will find the next-most-specific handler and execute it as well. So the previous example, could be re-written: return PUREBOOL { $_ = $return_val; next handler; } BOOL { defined $return_val && $return_val > 0 } SCALAR { $return_val; } Note that I specific handler can defer to a more general one in this same way. For example, you could provide consistent and maintainable type-checking for a subroutine that returns references by providing C, C, and C handlers that all defer to a generic C handler, like so: my $retval = _get_ref(); return SCALARREF { croak 'Type mismatch' if ref($retval) ne 'SCALAR'; next handler; } ARRAYREF { croak 'Type mismatch' if ref($retval) ne 'ARRAY'; next handler; } HASHREF { croak 'Type mismatch' if ref($retval) ne 'HASH'; next handler; } REF { $retval } If, at a later time, the process of returning a reference became more complex, only the C handler would have to be updated. =head2 Nested handlers Another way of factoring out return behaviour is to nest more specific handlers inside more general ones. For instance, in the final example given in L<"Boolean vs Pure Boolean contexts">: sub get_data { my $data; return PUREBOOL { _check_for_but_dont_get_data(); } BOOL { defined( $data ||= _go_and_get_data() ); } REF { $data ||= _go_and_get_data(); } } you could factor out the repeated calls to C<_go_and_get_data()> like so: sub get_data { return PUREBOOL { _check_for_but_dont_get_data(); } DEFAULT { my $data = _go_and_get_data(); BOOL { defined $data; } REF { $data; } } } Here, the C handler deals with every return context except pure boolean. Within that C handler, the data is first retrieved, and then two "sub-handlers" deal with the ordinary boolean and referential contexts. Typically nested handlers are used in precisely this way: to optimize for inexpensive special cases (such as pure boolean or integer or void return contexts) and only do extra work for those other cases that require it. =head2 Failure contexts Two of the most common ways to specify that a subroutine has failed are to return a false value, or to throw an exception. The Contextual::Return module provides a mechanism that allows the subroutine writer to support I of these mechanisms at the same time, by using the C specifier. A return statement of the form: return FAIL; causes the surrounding subroutine to return C (i.e. false) in boolean contexts, and to throw an exception in any other context. For example: use Contextual::Return; sub get_next_val { my $next_val = <>; return FAIL if !defined $next_val; chomp $next_val; return $next_val; } If the C statement is executed, it will either return false in a boolean context: if (my $val = get_next_val()) { # returns undef if no next val print "[$val]\n"; } or else throw an exception if the return value is used in any other context: print get_next_val(); # throws exception if no next val my $next_val = get_next_val(); print "[$next_val]\n"; # throws exception if no next val The exception that is thrown is of the form: Call to main::get_next_val() failed at demo.pl line 42 but you can change that message by providing a block to the C, like so: return FAIL { "No more data" } if !defined $next_val; in which case, the final value of the block becomes the exception message: No more data at demo.pl line 42 A failure value can be interrogated for its error message, by calling its C method, like so: my $val = get_next_val(); if ($val) { print "[$val]\n"; } else { print $val->error, "\n"; } =head2 Configurable failure contexts The default C behaviour--false in boolean context, fatal in all others--works well in most situations, but violates the Platinum Rule ("Do unto others as I would have done unto them"). So it may be user-friendlier if the user of a module is allowed decide how the module's subroutines should behave on failure. For example, one user might prefer that failing subs always return undef; another might prefer that they always throw an exception; a third might prefer that they always log the problem and return a special Failure object; whilst a fourth user might want to get back C<0> in scalar contexts, an empty list in list contexts, and an exception everywhere else. You could create a module that allows the user to specify all these alternatives, like so: package MyModule; use Contextual::Return; use Log::StdLog; sub import { my ($package, @args) = @_; Contextual::Return::FAIL_WITH { ':false' => sub { return undef }, ':fatal' => sub { croak @_ }, ':filed' => sub { print STDLOG 'Sub ', (caller 1)[3], ' failed'; return Failure->new(); }, ':fussy' => sub { SCALAR { undef } LIST { () } DEFAULT { croak @_ } }, }, @args; } This configures Contextual::Return so that, instead of the usual false-or-fatal semantics, every C within MyModule's namespace is implemented by one of the four subroutines specified in the hash that was passed to C. Which of those four subs implements the C is determined by the arguments passed after the hash (i.e. by the contents of C<@args>). C walks through that list of arguments and compares them against the keys of the hash. If a key matches an argument, the corresponding value is used as the implementation of C. Note that, if subsequent arguments also match a key, their subroutine overrides the previously installed implementation, so only the final override has any effect. Contextual::Return generates warnings when multiple overrides are specified. All of which mean that, if a user loaded the MyModule module like this: use MyModule qw( :fatal other args here ); then every C within MyModule would be reconfigured to throw an exception in all circumstances, since the presence of the C<':fatal'> in the argument list will cause C to select the hash entry whose key is C<':fatal'>. On the other hand, if they loaded the module: use MyModule qw( :fussy other args here ); then each C within MyModule would return undef or empty list or throw an exception, depending on context, since that's what the subroutine whose key is C<':fussy'> does. Many people prefer module interfaces with a C<< I => I >> format, and C supports this too. For example, if you wanted your module to take a C<-fail> flag, whose associated value could be any of C<"undefined">, C<"exception">, C<"logged">, or C<"context">, then you could implement that simply by specifying the flag as the first argument (i.e. I the hash) like so: sub import { my $package = shift; Contextual::Return::FAIL_WITH -fail => { 'undefined' => sub { return undef }, 'exception' => sub { croak @_ }, 'logged' => sub { print STDLOG 'Sub ', (caller 1)[3], ' failed'; return Failure->new(); }, 'context' => sub { SCALAR { undef } LIST { () } DEFAULT { croak @_ } }, }, @_; and then load the module: use MyModule qw( other args here ), -fail=>'undefined'; or: use MyModule qw( other args here ), -fail=>'exception'; In this case, C scans the argument list for a pair of values: its flag string, followed by some other selector value. Then it looks up the selector value in the hash, and installs the corresponding subroutine as its local C handler. If this "flagged" interface is used, the user of the module can also specify their own handler directly, by passing a subroutine reference as the selector value instead of a string: use MyModule qw( other args here ), -fail=>sub{ die 'horribly'}; If this last example were used, any call to C within MyModule would invoke the specified anonymous subroutine (and hence throw a 'horribly' exception). Note that, any overriding of a C handler is specific to the namespace and file from which the subroutine that calls C is itself called. Since C is designed to be called from within a module's C subroutine, that generally means that the Cs within a given module X are only overridden for the current namespace within the particular file from module X is loaded. This means that two separate pieces of code (in separate files or separate namespaces) can each independently overide a module's C behaviour, without interfering with each other. =head2 Lvalue contexts Recent versions of Perl offer (limited) support for lvalue subroutines: subroutines that return a modifiable variable, rather than a simple constant value. Contextual::Return can make it easier to create such subroutines, within the limitations imposed by Perl itself. The limitations that Perl places on lvalue subs are: =over =item 1. The subroutine must be declared with an C<:lvalue> attribute: sub foo :lvalue {...} =item 2. The subroutine must not return via an explicit C. Instead, the last statement must evaluate to a variable, or must be a call to another lvalue subroutine call. my ($foo, $baz); sub foo :lvalue { $foo; # last statement evals to a var } sub bar :lvalue { foo(); # last statement is lvalue sub call } sub baz :lvalue { my ($arg) = @_; $arg > 0 # last statement evals... ? $baz # ...to a var : bar(); # ...or to an lvalue sub call } =back Thereafter, any call to the lvalue subroutine produces a result that can be assigned to: baz(0) = 42; # same as: $baz = 42 baz(1) = 84; # same as: bar() = 84 # which is the same as: foo() = 84 # which is the same as: $foo = 84 Ultimately, every lvalue subroutine must return a scalar variable, which is then used as the lvalue of the assignment (or whatever other lvalue operation is applied to the subroutine call). Unfortunately, because the subroutine has to return this variable I the assignment can take place, there is no way that a normal lvalue subroutine can get access to the value that will eventually be assigned to its return value. This is occasionally annoying, so the Contextual::Return module offers a solution: in addition to all the context blocks described above, it provides three special contextual return blocks specifically for use in lvalue subroutines: C, C, and C. Using these blocks you can specify what happens when an lvalue subroutine is used in lvalue and non-lvalue (rvalue) context. For example: my $verbosity_level = 1; # Verbosity values must be between 0 and 5... sub verbosity :lvalue { LVALUE { $verbosity_level = max(0, min($_, 5)) } RVALUE { $verbosity_level } } The C block is executed whenever C is called as an lvalue: verbosity() = 7; The block has access to the value being assigned, which is passed to it as C<$_>. So, in the above example, the assigned value of 7 would be aliased to C<$_> within the C block, would be reduced to 5 by the "min-of-max" expression, and then assigned to C<$verbosity_level>. (If you need to access the caller's C<$_>, it's also still available: as C<$CALLER::_>.) When the subroutine isn't used as an lvalue: print verbosity(); the C block is executed instead and its final value returned. Within an C block you can use any of the other features of Contextual::Return. For example: sub verbosity :lvalue { LVALUE { $verbosity_level = int max(0, min($_, 5)) } RVALUE { NUM { $verbosity_level } STR { $description[$verbosity_level] } BOOL { $verbosity_level > 2 } } } but the context sequence must be nested inside an C block. You can also specify what an lvalue subroutine should do when it is used neither as an lvalue nor as an rvalue (i.e. in void context), by using an C block: sub verbosity :lvalue { my ($level) = @_; NVALUE { $verbosity_level = int max(0, min($level, 5)) } LVALUE { $verbosity_level = int max(0, min($_, 5)) } RVALUE { NUM { $verbosity_level } STR { $description[$verbosity_level] } BOOL { $verbosity_level > 2 } } } In this example, a call to C in void context sets the verbosity level to whatever argument is passed to the subroutine: verbosity(1); Note that you I get the same effect by nesting a C block within an C block: LVALUE { $verbosity_level = int max(0, min($_, 5)) } RVALUE { NUM { $verbosity_level } STR { $description[$verbosity_level] } BOOL { $verbosity_level > 2 } VOID { $verbosity_level = $level } # Wrong! } That's because, in a void context the return value is never evaluated, so it is never treated as an rvalue, which means the C block never executes. =head2 Result blocks Occasionally, it's convenient to calculate a return value I the end of a contextual return block. For example, you may need to clean up external resources involved in the calculation after it's complete. Typically, this requirement produces a slightly awkward code sequence like this: return VALUE { $db->start_work(); my $result = $db->retrieve_query($query); $db->commit(); $result; } Such code sequences become considerably more awkward when you want the return value to be context sensitive, in which case you have to write either: return LIST { $db->start_work(); my @result = $db->retrieve_query($query); $db->commit(); @result; } SCALAR { $db->start_work(); my $result = $db->retrieve_query($query); $db->commit(); $result; } or, worse: return VALUE { $db->start_work(); my $result = LIST ? [$db->retrieve_query($query)] : $db->retrieve_query($query); $db->commit(); LIST ? @{$result} : $result; } To avoid these infelicities, Contextual::Return provides a second way of setting the result of a context block; a way that doesn't require that the result be the last statement in the block: return LIST { $db->start_work(); RESULT { $db->retrieve_query($query) }; $db->commit(); } SCALAR { $db->start_work(); RESULT { $db->retrieve_query($query) }; $db->commit(); } The presence of a C block inside a contextual return block causes that block to return the value of the final statement of the C block as the handler's return value, rather than returning the value of the handler's own final statement. In other words, the presence of a C block overrides the normal return value of a context handler. Better still, the C block always evaluates its final statement in the same context as the surrounding C, so you can just write: return VALUE { $db->start_work(); RESULT { $db->retrieve_query($query) }; $db->commit(); } and the C method will be called in the appropriate context in all cases. A C block can appear anywhere inside any contextual return block, but may not be used outside a context block. That is, this is an error: if ($db->closed) { RESULT { undef }; # Error: not in a context block } return VALUE { $db->start_work(); RESULT { $db->retrieve_query($query) }; $db->commit(); } =head2 Post-handler clean-up If a subroutine uses an external resource, it's often necessary to close or clean-up that resource after the subroutine ends...regardless of whether the subroutine exits normally or via an exception. Typically, this is done by encapsulating the resource in a lexically scoped object whose destructor does the clean-up. However, if the clean-up doesn't involve deallocation of an object (as in the C<< $db->commit() >> example in the previous section), it can be annoying to have to create a class and allocate a container object, merely to mediate the clean-up. To make it easier to manage such resources, Contextual::Return supplies a special labelled block: the C block. If a C block is specified as part of a contextual return sequence, that block is executed after any context handler, even if the context handler exits via an exception. So, for example, you could implement a simple commit-or-revert policy like so: return LIST { $db->retrieve_all($query) } SCALAR { $db->retrieve_next($query) } RECOVER { if ($@) { $db->revert(); } else { $db->commit(); } } The presence of a C block also intercepts all exceptions thrown in any other context block in the same contextual return sequence. Any such exception is passed into the C block in the usual manner: via the C<$@> variable. The exception may be rethrown out of the C block by calling C: return LIST { $db->retrieve_all($query) } DEFAULT { croak "Invalid call (not in list context)" } RECOVER { die $@ if $@; # Propagate any exception $db->commit(); # Otherwise commit the changes } A C block can also access or replace the returned value, by invoking a C block. For example: return LIST { attempt_to_generate_list_for(@_) } SCALAR { attempt_to_generate_count_for(@_) } RECOVER { if ($@) { # On any exception... warn "Replacing return value. Previously: ", RESULT; RESULT { undef } # ...return undef } } =head2 Post-return clean-up Occasionally it's necessary to defer the clean-up of resources until after the return value has been used. Once again, this is usually done by returning an object with a suitable destructor. Using Contextual::Return you can get the same effect, by providing a C block in the contextual return sequence: return LIST { $db->retrieve_all($query) } SCALAR { $db->retrieve_next($query) } CLEANUP { $db->commit() } In this example, the C method call is only performed after the return value has been used by the caller. Note that this is quite different from using a C block, which is called as the subroutine returns its value; a C is called when the returned value is garbage collected. A C block is useful for controlling resources allocated to support an C return value. For example: my %file; # Return an active value that is always the next line from a file... sub readline_from { my ($file_name) = @_; # Open the file, if not already open... if (!$file{$file_name}) { open $file{$file_name}{handle}, '<', $file_name; } # Track how many active return values are using this file... $file{$file_name}{count}++; return ACTIVE # Evaluating the return value returns the next line... VALUE { readline $file{$file_name}{handle} } # Once the active value is finished with, clean up the filehandle... CLEANUP { delete $file{$file_name} if --$file{$file_name}{count} == 0; } } =head2 Debugging contextual return values Contextual return values are implemented as opaque objects (using the "inside-out" technique). This means that passing such values to Data::Dumper produces an uninformative output like: $VAR1 = bless( do{\(my $o = undef)}, 'Contextual::Return::Value' ); So the module provides two methods that allow contextual return values to be correctly reported: either directly, or when dumped by Data::Dumper. To dump a contextual return value directly, call the module's C method explicitly and print the result: print $crv->Contextual::Return::DUMP(); This produces an output something like: [ { FROM => 'main::foo' }, { NO_HANDLER => [ 'VOID', 'CODEREF', 'HASHREF', 'GLOBREF' ] }, { FALLBACKS => [ 'VALUE' ] }, { LIST => [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 ] }, { STR => '<<>>' }, { NUM => 42 }, { BOOL => -1 }, { SCALARREF => '<<>>' }, { ARRAYREF => [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 ] }, ]; The C hash entry names the subroutine that produced the return value. The C hash entry lists those contexts for which no handler was defined (and which would therefore normally produce "can't call" exceptions such as: C<"Can't call main::foo in VOID context">). The C hash entry lists any "generic" contexts such as C, C, C, C, etc. that the contextual return value can also handle. After these, all the remaining hash entries are actual contexts in which the return value could successfully be evaluated, and the value it would produce in each of those contexts. The Data::Dumper module also has a mechanism by which you can tell it how to produce a similar listing automatically whenever a contextual return value is passed to its C method. Data::Dumper allows you to register a "freezer" method, that is called prior to dumping, and which can be used to adapt an opaque object to make it dumpable. Contextual::Return provides just such a method (C) for you to register, like so: use Data::Dumper 'Dumper'; local $Data::Dumper::Freezer = 'Contextual::Return::FREEZE'; print Dumper $foo; The output is then precisely the same as C would produce. Note that, with both of the above dumping mechanisms, it is essential to use the full name of the method. That is: print $crv->Contextual::Return::DUMP(); rather than: print $crv->DUMP(); This is because the shorter version is interpreted as calling the C method on the object returned by the return value's C context block (see L<"Scalar reference contexts">) For the same reason, you must write: local $Data::Dumper::Freezer = 'Contextual::Return::FREEZE'; not: local $Data::Dumper::Freezer = 'FREEZE'; =head2 Namespace controls By default the module exports a large number of return context markers: DEFAULT REF LAZY VOID SCALARREF FIXED NONVOID ARRAYREF ACTIVE LIST CODEREF RESULT SCALAR HASHREF RECOVER VALUE GLOBREF CLEANUP STR OBJREF RVALUE NUM METHOD LVALUE BOOL NVALUE PUREBOOL These are exported as subroutines, and so can conflict with existing subroutines in your namespace, or with subroutines imported from other modules. Contextual::Return allows you to control which contextual return blocks are exported into any namespace that uses the module. It also allows you to rename blocks to avoid namespace conflicts with existing subroutines. Both these features are controlled by passing arguments to the C statement that loads the module as follows: =over =item * Any string passed as an argument to C, exports only the block name it specifies; =item * Any regex passed as an argument to C exports every block name it matches; =item * Any array ref (recursively) exports each of its elements =item * Any string that appears immediately after one of the above three specifiers, and which is not itself a block name, renames the handlers exported by that preceding specifier by filtering each handler name through C =back That is, you can specify handlers to be exported by exact name (as a string), by general pattern (as a regex), or collectively (in an array). And after any of these export specifications, you can append a template in which any C<'%s'> will be replaced by the original name of the handler. For example: # Selectively export specific sets of handlers... use Contextual::Return qr/[NLR]VALUE/; use Contextual::Return qr/.*REF/; # Selective export specific sets and add a suffix to each... use Contextual::Return qr/[NLR]VALUE/ => '%s_CONTEXT'; # Selective export specific sets and add a prefix to each... use Contextual::Return qr/.*REF/ => 'CR_%s'; # Export a list of handlers... use Contextual::Return 'NUM', 'STR', 'BOOL' ; use Contextual::Return qw< NUM STR BOOL >; use Contextual::Return ['NUM', 'STR', 'BOOL']; # Export a list of handlers, renaming them individually... use Contextual::Return NUM => 'NUMERIC', STR => 'TEXT', BOOL => 'CR_%s'; # Export a list of handlers, renaming them collectively... use Contextual::Return ['NUM', 'STR', 'BOOL'] => '%s_CONTEXT'; # Mixed exports and renames... use Contextual::Return ( STR => 'TEXT', ['NUM', 'BOOL'] => 'CR_%s', ['LIST', 'SCALAR', 'VOID', qr/^[NLR]VALUE/] => '%s_CONTEXT', ); =head1 INTERFACE =head2 Context tests =over =item C<< LIST() >> Returns true if the current subroutine was called in list context. A cleaner way of writing: C<< wantarray() >> =item C<< SCALAR() >> Returns true if the current subroutine was called in scalar context. A cleaner way of writing: C<< defined wantarray() && ! wantarray() >> =item C<< VOID() >> Returns true if the current subroutine was called in void context. A cleaner way of writing: C<< !defined wantarray() >> =item C<< NONVOID() >> Returns true if the current subroutine was called in list or scalar context. A cleaner way of writing: C<< defined wantarray() >> =back =head2 Standard contexts =over =item C<< LIST {...} >> The block specifies what the context sequence should evaluate to when called in list context. =item C<< SCALAR {...} >> The block specifies what the context sequence should evaluate to in scalar contexts, unless some more-specific specifier scalar context specifier (see below) also occurs in the same context sequence. =item C<< VOID {...} >> The block specifies what the context sequence should do when called in void context. =back =head2 Scalar value contexts =over =item C<< BOOL {...} >> The block specifies what the context sequence should evaluate to when treated as a boolean value. =item C<< NUM {...} >> The block specifies what the context sequence should evaluate to when treated as a numeric value. =item C<< STR {...} >> The block specifies what the context sequence should evaluate to when treated as a string value. =item C<< LAZY {...} >> Another name for C. Usefully self-documenting when the primary purpose of the contextual return is to defer evaluation of the return value until it's actually required. =back =head2 Scalar reference contexts =over =item C<< SCALARREF {...} >> The block specifies what the context sequence should evaluate to when treated as a reference to a scalar. =item C<< ARRAYREF {...} >> The block specifies what the context sequence should evaluate to when treated as a reference to an array. =item C<< HASHREF {...} >> The block specifies what the context sequence should evaluate to when treated as a reference to a hash. Note that a common error here is to write: HASHREF { a=>1, b=>2, c=>3 } The curly braces there are a block, not a hash constructor, so the block doesn't return a hash reference and the interpreter throws an exception. What's needed is: HASHREF { {a=>1, b=>2, c=>3} } in which the inner braces I a hash constructor. =item C<< CODEREF {...} >> The block specifies what the context sequence should evaluate to when treated as a reference to a subroutine. =item C<< GLOBREF {...} >> The block specifies what the context sequence should evaluate to when treated as a reference to a typeglob. =item C<< OBJREF {...} >> The block specifies what the context sequence should evaluate to when treated as a reference to an object. =item C<< METHOD {...} >> The block can be used to specify particular handlers for specific method calls when the return value is treated as an object reference. It should return a list of methodname/methodbody pairs. Each method name can be specified as a string, a regex, or an array of strings or regexes. The method bodies must be specified as subroutine references (usually anonymous subs). The first method name that matches the actual method call selects the corresponding handler, which is then called. =back =head2 Generic contexts =over =item C<< VALUE {...} >> The block specifies what the context sequence should evaluate to when treated as a non-referential value (as a boolean, numeric, string, scalar, or list). Only used if there is no more-specific value context specifier in the context sequence. =item C<< REF {...} >> The block specifies what the context sequence should evaluate to when treated as a reference of any kind. Only used if there is no more-specific referential context specifier in the context sequence. =item C<< NONVOID {...} >> The block specifies what the context sequence should evaluate to when used in a non-void context of any kind. Only used if there is no more-specific context specifier in the context sequence. =item C<< DEFAULT {...} >> The block specifies what the context sequence should evaluate to when used in a void or non-void context of any kind. Only used if there is no more-specific context specifier in the context sequence. =back =head2 Failure context =over =item C<< FAIL >> This block is executed unconditionally and is used to indicate failure. In a Boolean context it return false. In all other contexts it throws an exception consisting of the final evaluated value of the block. That is, using C: return FAIL { "Could not defenestrate the widget" } is exactly equivalent to writing: return BOOL { 0 } DEFAULT { croak "Could not defenestrate the widget" } except that the reporting of errors is a little smarter under C. If C is called without specifying a block: return FAIL; it is equivalent to: return FAIL { croak "Call to failed" } (where C<< >> is replaced with the name of the surrounding subroutine). Note that, because C implicitly covers every possible return context, it cannot be chained with other context specifiers. =item C<< Contextual::Return::FAIL_WITH >> This subroutine is not exported, but may be called directly to reconfigure C behaviour in the caller's namespace. The subroutine is called with an optional string (the I), followed by a mandatory hash reference (the I), followed by a list of zero-or-more strings (the I). The values of the configurations hash must all be subroutine references. If the optional flag is specified, C searches the selector list looking for that string, then uses the I item in the selector list as its I. If that selector value is a string, C looks up that key in the hash, and installs the corresponding subroutine as the namespace's C handler (an exception is thrown if the selector string is not a valid key of the configurations hash). If the selector value is a subroutine reference, C installs that subroutine as the C handler. If the optional flag is I specified, C searches the entire selector list looking for the last element that matches any key in the configurations hash. It then looks up that key in the hash, and installs the corresponding subroutine as the namespace's C handler. See L for examples of using this feature. =back =head2 Lvalue contexts =over =item C<< LVALUE >> This block is executed when the result of an C<:lvalue> subroutine is assigned to. The assigned value is passed to the block as C<$_>. To access the caller's C<$_> value, use C<$CALLER::_>. =item C<< RVALUE >> This block is executed when the result of an C<:lvalue> subroutine is used as an rvalue. The final value that is evaluated in the block becomes the rvalue. =item C<< NVALUE >> This block is executed when an C<:lvalue> subroutine is evaluated in void context. =back =head2 Explicit result blocks =over =item C<< RESULT >> This block may only appear inside a context handler block. It causes the surrounding handler to return the final value of the C's block, rather than the final value of the handler's own block. This override occurs regardless of the location to the C block within the handler. If called without a trailing C<{...}>, it simply returns the current result value in scalar contexts, or the list of result values in list context. =back =head2 Recovery blocks =over =item C<< RECOVER >> If present in a context return sequence, this block grabs control after any context handler returns or exits via an exception. If an exception was thrown it is passed to the C block via the C<$@> variable. =back =head2 Clean-up blocks =over =item C<< CLEANUP >> If present in a context return sequence, this block grabs control when a return value is garbage collected. =back =head2 Modifiers =over =item C<< FIXED >> This specifies that the scalar value will only be evaluated once, the first time it is used, and that the value will then morph into that evaluated value. =item C<< ACTIVE >> This specifies that the scalar value's originating block will be re- evaluated every time the return value is used. =back =head2 Debugging support =over =item C<< $crv->Contextual::Return::DUMP() >> Dump a representation of the return value in all viable contexts =item C<< local $Data::Dumper::Freezer = 'Contextual::Return::FREEZE' >> Configure Data::Dumper to correctly dump a representation of the return value. =back =head1 DIAGNOSTICS =over =item C In your C statement you specified something (such as a hash or coderef) that can't be used to select what the module exports. Make sure the list of selectors includes only strings, regexes, or references to arrays of strings or regexes. =item C In your C statement you specified a regex to select which handlers to support, but the regex didn't select any handlers. Check that the regex you're using actually does match at least one of the names of the modules many handlers. =item C In your C statement you specified a string as the name of a context handler to be exported, but the module doesn't export a handler of that name. Check the spelling for the requested export. =item C =item C The subroutine you called uses a contextual return, but doesn't specify what to return in the particular context in which you called it. You either need to change the context in which you're calling the subroutine, or else add a context block corresponding to the offending context (or perhaps a C block). =item C You specified a handler (such as C or C) outside any subroutine, and in a context that it can't handle. Did you mean to place the handler outside of a subroutine? If so, then you need to put it in a context it can actually handle. Otherwise, perhaps you need to replace the trailing block with parens (that is: C or C). =item C You called the subroutine in a context that expected to get back a reference of some kind but the subroutine didn't specify the corresponding C, C, C, C, C, or generic C, C, or C handlers. You need to specify the appropriate one of these handlers in the subroutine. =item C You called the subroutine and then tried to call a method on the return value, but the subroutine returned a classname or object that doesn't have that method. This probably means that the subroutine didn't return the classname or object you expected. Or perhaps you need to specify an C context block. =item C You attempted to specify two context blocks of the same name in the same return context, which is ambiguous. For example: sub foo: lvalue { LVALUE { $foo = $_ } RVALUE { $foo } LVALUE { $foo = substr($_,1,10) } } or: sub bar { return BOOL { 0 } NUM { 1 } STR { "two" } BOOL { 1 }; } Did you cut-and-paste wrongly, or mislabel one of the blocks? =item C If you specify any of C, C, or C, then you can only specify C, C, or C blocks in the same return context. If you need to specify other contexts (like C, or C, or C, etc.), put them inside an C block. See L for an example. =item C This is the default exception that a C throws in a non-scalar context. Which means that the subroutine you called has signalled failure by throwing an exception, and you didn't catch that exception. You should either put the call in an C block or else call the subroutine in boolean context instead. =item C This is the default exception that a C throws when a failure value is captured in a scalar variable and later used in a non-boolean context. That means that the subroutine you called must have failed, and you didn't check the return value for that failure, so when you tried to use that invalid value it killed your program. You should either put the original call in an C or else test the return value in a boolean context and avoid using it if it's false. =item C The C subroutine expects an optional flag, followed by a reference to a configuration hash, followed by a list or selector arguments. You gave it something else. See L. =item C You passed a configuration hash to C that specified non- subroutines as possible C handlers. Since non-subroutines can't possibly be handlers, maybe you forgot the C keyword somewhere? =item C %s> The C subroutine was passed a flag/selector pair, but the selector was not one of those allowed by the configuration hash. =item C A warning that the C handler for a particular package was reconfigured more than once. Typically that's because the module was loaded in two places with difference configurations specified. You can't reasonably expect two different sets of behaviours from the one module within the one namespace. =back =head1 CONFIGURATION AND ENVIRONMENT Contextual::Return requires no configuration files or environment variables. =head1 DEPENDENCIES Requires version.pm and Want.pm. =head1 INCOMPATIBILITIES C, C, and C do not work correctly under the Perl debugger. This seems to be because the debugger injects code to capture the return values from subroutines, which interferes destructively with the optional final arguments that allow C, C, and C to cascade within a single return. =head1 BUGS AND LIMITATIONS No bugs have been reported. =head1 AUTHOR Damian Conway C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2005-2011, Damian Conway C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Contextual-Return-0.004008/lib/Contextual/Return/Failure.pm000644 000765 000765 00000011314 12364230523 023034 0ustar00damian000000 000000 package Contextual::Return::Failure; our $VERSION = 0.000_003; use Contextual::Return; BEGIN { *_in_context = *Contextual::Return::_in_context } use warnings; use strict; my %handler_for; sub _FAIL_WITH { # Unpack and vet args... my $flag = shift; my $selector_ref; if (ref $flag eq 'HASH') { $selector_ref = $flag; $flag = undef; } else { $selector_ref = shift; die _in_context 'Usage: FAIL_WITH $flag_opt, \%selector, @args' if ref $selector_ref ne 'HASH'; } die _in_context "Selector values must be sub refs" if grep {ref ne 'CODE'} values %{$selector_ref}; # Search for handler sub; my $handler; if (defined $flag) { ARG: while (@_) { last ARG if shift(@_) eq $flag; } my $selector = shift @_; if (ref $selector eq 'CODE') { $handler = $selector; @_ = (); } else { @_ = $selector; } } SELECTION: for my $selection (reverse @_) { if (exists $selector_ref->{$selection}) { $handler = $selector_ref->{$selection}; last SELECTION; } elsif ($flag) { die _in_context "Invalid option: $flag => $selection"; } } # (Re)set handler... if ($handler) { my $caller_loc = join '|', (CORE::caller 1)[0,1]; if (exists $handler_for{$caller_loc}) { warn _in_context "FAIL handler for package ", scalar CORE::caller, " redefined"; } $handler_for{$caller_loc} = $handler; } }; sub _FAIL (;&) { # Generate args... my $arg_generator_ref = shift; my @args; if ($arg_generator_ref) { package DB; ()=CORE::caller(1); @args = $arg_generator_ref->(@DB::args); } # Handle user-defined failure semantics... my $caller_loc = join '|', (CORE::caller 1)[0,1]; if (exists $handler_for{$caller_loc} ) { # Fake out caller() and Carp... local $Contextual::Return::uplevel = 1; return $handler_for{$caller_loc}->(@args); } my $exception = @args == 1 ? $args[0] : @args > 0 ? join(q{}, @args) : "Call to " . (CORE::caller 1)[3] . "() failed" ; # Join message with croak() semantics, if string... if (!ref $exception) { $exception .= _in_context @_; } # # Check for immediate failure... # use Want qw( want ); # return 0 if want 'BOOL'; # die $exception if !want 'SCALAR'; # Return a delayed failure object... return BOOL { 0 } DEFAULT { if (ref $exception) { my $message = "$exception"; $message =~ s/$/\n/; die _in_context $message, "Attempted to use failure value"; } else { die _in_context $exception, "Attempted to use failure value"; } } METHOD { error => sub { _in_context $exception } } } 1; __END__ =head1 NAME Contextual::Return::Failure - Utility module for Contextual::Return =head1 NOTE Contains no user serviceable parts. See L instead. =head1 AUTHOR Damian Conway C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2006, Damian Conway C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.