File Coverage

blib/lib/Return/MultiLevel.pm

Criterion	Covered	Total	%
statement	21	21	100.0
branch	5	6	83.3
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	33	34	97.0

package Return::MultiLevel;

use strict;
use warnings;
use 5.008001;
use Carp qw(confess);
use parent 'Exporter';

# ABSTRACT: Return across multiple call levels
our $VERSION = '0.07_01'; # TRIAL VERSION
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)

our @EXPORT_OK = qw(with_return);

our $_backend;

sub with_return (&);

if (!$ENV{RETURN_MULTILEVEL_PP} && eval { require Scope::Upper }) {

  *with_return = sub (&) {
    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);
    })
  };

  $_backend = 'XS';

} else {

  *_label_at = do {
    my $_label_prefix = '_' . __PACKAGE__ . '_';
    $_label_prefix =~ tr/A-Za-z0-9_/_/cs;

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

  our @_trampoline_cache;

  *_get_trampoline = sub {
    my ($i) = @_;
    my $label = _label_at($i);
    (
      $label,
      $_trampoline_cache[$i] ||= eval ## no critic (BuiltinFunctions::ProhibitStringyEval)
      qq{
        sub {
          my \$rr = shift;
          my \$fn = shift;
          return &\$fn;
          $label: splice \@\$rr
        }
      },
    )
  };

  our $_depth = 0;

  *with_return = sub (&) {
    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;
      },
    )
  };

    $_backend = 'PP';
}

1;

__END__