Return::MultiLevel

package Return::MultiLevel;

use warnings;
use strict;

our $VERSION = '0.03';

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;
    local $ctx[0] = Scope::Upper::HERE();
    $f->(sub {
        defined $ctx[0]
            or confess "Attempt to re-enter dead call frame";
        Scope::Upper::unwind(@_, $ctx[0]);
    })
}
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;
    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 = Carp::longmess "Original call to with_return";
    local $canary[0];
    my @ret;
    $trampoline->(
        \@ret,
        $f,
        sub {
            $canary[0]
                and confess "Captured stack:\n$canary[0]\nAttempt to re-enter dead call frame";
            @ret = @_;
            goto $label;
        },
    )
}
EOT

    $_backend = 'PP';
}

'ok'

__END__