File Coverage

blib/lib/Return/MultiLevel.pm

Criterion	Covered	Total	%
statement	22	22	100.0
branch	5	6	83.3
condition			n/a
subroutine	7	7	100.0
pod	1	1	100.0
total	35	36	97.2

package Return::MultiLevel;

use warnings;
use strict;

our $VERSION = '0.06';

use Carp qw(confess);
use Data::Munge qw(eval_string);
use parent 'Exporter';

our @EXPORT_OK = qw(with_return);

our $_backend;

if (!$ENV{RETURN_MULTILEVEL_PP} && eval { require Scope::Upper }) {
    eval_string <<'EOT';
sub with_return (&) {
    my ($f) = @_;
    my $ctx = Scope::Upper::HERE();
    my @canary =
        !$ENV{RETURN_MULTILEVEL_DEBUG}
            ? '-'
            : Carp::longmess "Original call to with_return"
    ;
    local $canary[0];
    $f->(sub {
        $canary[0]
            and confess
                $canary[0] eq '-'
                    ? ""
                    : "Captured stack:\n$canary[0]\n",
                "Attempt to re-enter dead call frame"
        ;
        Scope::Upper::unwind(@_, $ctx);
    })
}
EOT

    $_backend = 'XS';

} else {

    eval_string <<'EOT';
{
    my $_label_prefix = '_' . __PACKAGE__ . '_';
    $_label_prefix =~ tr/A-Za-z0-9_/_/cs;

    sub _label_at { $_label_prefix . $_[0] }
}

our @_trampoline_cache;

sub _get_trampoline {
    my ($i) = @_;
    my $label = _label_at $i;
    (
        $label,
        $_trampoline_cache[$i] ||= eval_string qq{
            sub {
                my \$rr = shift;
                my \$fn = shift;
                return &\$fn;
                $label: splice \@\$rr
            }
        },
    )
}

our $_depth = 0;

sub with_return (&) {
    my ($f) = @_;
    my ($label, $trampoline) = _get_trampoline $_depth;
    local $_depth = $_depth + 1;
    my @canary =
        !$ENV{RETURN_MULTILEVEL_DEBUG}
            ? '-'
            : Carp::longmess "Original call to with_return"
    ;
    local $canary[0];
    my @ret;
    $trampoline->(
        \@ret,
        $f,
        sub {
            $canary[0]
                and confess
                    $canary[0] eq '-'
                        ? ""
                        : "Captured stack:\n$canary[0]\n",
                    "Attempt to re-enter dead call frame"
            ;
            @ret = @_;
            goto $label;
        },
    )
}
EOT

    $_backend = 'PP';
}

'ok'

__END__