File Coverage

blib/lib/Contextual/Return.pm

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

package Contextual::Return;
use warnings;
use strict;
our $VERSION = '0.004011';

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");
        }
        no if $] >= 5.022, warnings => 'redundant';
        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};
        no if $] >= 5.022, warnings => 'redundant';
        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]; my $args = \@DB::args; ()=CORE::caller(1); $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); my $args = \@DB::args; ()=CORE::caller(1); $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); my $args = \@DB::args; ()=CORE::caller(1); $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); my $args = \@DB::args; ()=CORE::caller(1); $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); my $args = \@DB::args; ()=CORE::caller(1); $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); my $args = \@DB::args; ()=CORE::caller(1); $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 $ref ( $type eq 'SCALAR' ? ${$data_ref} : $type eq 'ARRAY' ? @{$data_ref} : ()) {
        no warnings 'numeric', 'uninitialized';
        if (refaddr($ref) == refaddr($obj_ref)) {
            $ref = '<<>>';
        }
    }
}

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 ();
            }
            chomp $exception;
            return { $context => "<<>>" };
        }

        # Detect self-referential overloadings (to avoid infinite recursion)...
        {
            no warnings 'numeric', 'uninitialized';
            if (ref $retval eq 'REF' && eval{ ${$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 => eval{ [ _internal_LIST(sub{}, $self) ] } // do{ chomp $@; "<<>>"} };
        _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 (eval{ require Data::Dumper; 1; }) {
        my ($crv) = @_;
        if (eval{ ref($crv)->isa('Contextual::Return::Value')}) {
            Contextual::Return::FREEZE($crv);
        }
        local $Data::Dumper::Terse = 1;
        local $Data::Dumper::Indent = 1;
        my $dump = Data::Dumper::Dumper($crv);
        $dump =~ s<,\n  \{><,ZZZZ{>msg;
        $dump =~ s<\n\s+>< >msg;
        $dump =~ s<,ZZZZ\{><\n  {>msg;
        return $dump;
    }
    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__