Return-MultiLevel-0.04/0000755000175000017500000000000012403115344013757 5ustar maukemaukeReturn-MultiLevel-0.04/README0000644000175000017500000000176612403115212014643 0ustar maukemaukeReturn-MultiLevel Return across multiple call levels INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Return::MultiLevel You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Return-MultiLevel AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Return-MultiLevel CPAN Ratings http://cpanratings.perl.org/d/Return-MultiLevel MetaCPAN https://metacpan.org/module/Return::MultiLevel COPYRIGHT AND LICENCE Copyright (C) 2013-2014 Lukas Mai This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. Return-MultiLevel-0.04/Changes0000644000175000017500000000115412403115212015245 0ustar maukemaukeRevision history for Return-MultiLevel 0.04 2014-09-07 - switch to Data::Munge::eval_string - make with_return a named sub to improve stack traces - cache runtime generated trampolines; should cut down on the need to eval strings at runtime - document RETURN_MULTI_LEVEL_PP - add RETURN_MULTI_LEVEL_DEBUG for capturing with_return stacks 0.03 2013-08-06 - require 5.8 because 5.6 segfaults for some reason 0.02 2013-08-01 - drop dependency on Scope::OnExit::Wrap 0.01 2013-01-04 First version, released on an unsuspecting world. Return-MultiLevel-0.04/lib/0000755000175000017500000000000012403115344014525 5ustar maukemaukeReturn-MultiLevel-0.04/lib/Return/0000755000175000017500000000000012403115344016004 5ustar maukemaukeReturn-MultiLevel-0.04/lib/Return/MultiLevel.pm0000644000175000017500000001170412403115212020421 0ustar maukemaukepackage Return::MultiLevel; use warnings; use strict; our $VERSION = '0.04'; 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__ =head1 NAME Return::MultiLevel - return across multiple call levels =head1 SYNOPSIS use Return::MultiLevel qw(with_return); sub inner { my ($f) = @_; $f->(42); # implicitly return from 'with_return' below print "You don't see this\n"; } sub outer { my ($f) = @_; inner($f); print "You don't see this either\n"; } my $result = with_return { my ($return) = @_; outer($return); die "Not reached"; }; print $result, "\n"; # 42 =head1 DESCRIPTION This module provides a way to return immediately from a deeply nested call stack. This is similar to exceptions, but exceptions don't stop automatically at a target frame (and they can be caught by intermediate stack frames using L|perlfunc/eval-EXPR>). In other words, this is more like L/L than L|perlfunc/die-LIST>. Another way to think about it is that the "multi-level return" coderef represents a single-use/upward-only continuation. =head2 Functions The following functions are available (and can be imported on demand). =over =item with_return BLOCK Executes I, passing it a code reference (called C<$return> in this description) as a single argument. Returns whatever I returns. If C<$return> is called, it causes an immediate return from C. Any arguments passed to C<$return> become C's return value (if C is in scalar context, it will return the last argument passed to C<$return>). It is an error to invoke C<$return> after its surrounding I has finished executing. In particular, it is an error to call C<$return> twice. =back =head1 DEBUGGING This module uses L|Scope::Upper/unwind> from L|Scope::Upper> to do its work. If L|Scope::Upper> is not available, it substitutes its own pure Perl implementation. You can force the pure Perl version to be used regardless by setting the environment variable C to 1. If you get the error message C, that means something has called a C<$return> from outside of its C block. You can get a stack trace of where that C was by setting the environment variable C to 1. =head1 BUGS AND LIMITATIONS You can't use this module to return across implicit function calls, such as signal handlers (like C<$SIG{ALRM}>) or destructors (C). These are invoked automatically by perl and not part of the normal call chain. =head1 AUTHOR Lukas Mai, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2013-2014 Lukas Mai. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut Return-MultiLevel-0.04/META.yml0000644000175000017500000000130512403115344015227 0ustar maukemauke--- abstract: 'return across multiple call levels' author: - 'Lukas Mai ' build_requires: Test::Fatal: '0' Test::More: '0' configure_requires: ExtUtils::MakeMaker: '6.48' strict: '0' warnings: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Return-MultiLevel no_index: directory: - t - inc requires: Carp: '0' Data::Munge: '0.07' Exporter: '0' parent: '0' perl: '5.008000' strict: '0' warnings: '0' resources: repository: git://github.com/mauke/Return-MultiLevel.git version: '0.04' Return-MultiLevel-0.04/META.json0000644000175000017500000000257212403115344015406 0ustar maukemauke{ "abstract" : "return across multiple call levels", "author" : [ "Lukas Mai " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Return-MultiLevel", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.48", "strict" : "0", "warnings" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Data::Munge" : "0.07", "Exporter" : "0", "parent" : "0", "perl" : "5.008000", "strict" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Test::Fatal" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/mauke/Return-MultiLevel.git", "web" : "https://github.com/mauke/Return-MultiLevel" } }, "version" : "0.04" } Return-MultiLevel-0.04/Makefile.PL0000644000175000017500000000362412403114246015736 0ustar maukemaukeuse strict; use warnings; use ExtUtils::MakeMaker; sub merge_key_into { my ($href, $target, $source) = @_; %{$href->{$target}} = (%{$href->{$target}}, %{delete $href->{$source}}); } my %opt = ( NAME => 'Return::MultiLevel', AUTHOR => q{Lukas Mai }, VERSION_FROM => 'lib/Return/MultiLevel.pm', ABSTRACT_FROM => 'lib/Return/MultiLevel.pm', LICENSE => 'perl', PL_FILES => {}, MIN_PERL_VERSION => '5.8.0', CONFIGURE_REQUIRES => { 'strict' => 0, 'warnings' => 0, 'ExtUtils::MakeMaker' => '6.48', }, BUILD_REQUIRES => {}, TEST_REQUIRES => { 'Test::More' => 0, 'Test::Fatal' => 0, }, PREREQ_PM => { 'warnings' => 0, 'strict' => 0, 'parent' => 0, 'Carp' => 0, 'Data::Munge' => '0.07', 'Exporter' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Return-MultiLevel-*' }, META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { url => 'git://github.com/mauke/Return-MultiLevel.git', web => 'https://github.com/mauke/Return-MultiLevel', type => 'git', }, }, }, ); (my $mm_version = ExtUtils::MakeMaker->VERSION) =~ tr/_//d; if ($mm_version < 6.67_04) { # Why? For the glory of satan, of course! no warnings qw(redefine); *ExtUtils::MM_Any::_add_requirements_to_meta_v1_4 = \&ExtUtils::MM_Any::_add_requirements_to_meta_v2; } if ($mm_version < 6.63_03) { merge_key_into \%opt, 'BUILD_REQUIRES', 'TEST_REQUIRES'; } if ($mm_version < 6.55_01) { merge_key_into \%opt, 'CONFIGURE_REQUIRES', 'BUILD_REQUIRES'; } if ($mm_version < 6.51_03) { merge_key_into \%opt, 'PREREQ_PM', 'CONFIGURE_REQUIRES'; } WriteMakefile %opt; Return-MultiLevel-0.04/MANIFEST0000644000175000017500000000042012403115344015104 0ustar maukemaukeChanges MANIFEST Makefile.PL README lib/Return/MultiLevel.pm t/00-load.t t/basic.t t/debug.t t/nested.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Return-MultiLevel-0.04/t/0000755000175000017500000000000012403115344014222 5ustar maukemaukeReturn-MultiLevel-0.04/t/debug.t0000644000175000017500000000141012403111502015461 0ustar maukemauke#!perl use Test::More tests => 2; use Test::Fatal; use warnings FATAL => 'all'; use strict; BEGIN { $ENV{RETURN_MULTILEVEL_DEBUG} = 1; } use Return::MultiLevel qw(with_return); sub foo { my $naughty; with_return { $naughty = $_[0]; }; $naughty } sub bar { foo @_ } sub baz { my $f = shift; $f->(@_) } my $ret = bar; my $exc = exception { baz $ret, 'ducks'; }; like $exc, qr{ .* \bwith_return\b .* \Q${\__FILE__}\E .* \b 14 \b .* \n .* \bfoo\b .* \Q${\__FILE__}\E .* \b 19 \b .* \n .* \bbar\b .* \Q${\__FILE__}\E .* \b 27 \b .* \n }x; like $exc, qr{ .* \bReturn::MultiLevel\b .* \bducks\b .* \Q${\__FILE__}\E .* \b 24 \b .* \n .* \bbaz\b .* \bducks\b .* \Q${\__FILE__}\E .* \b 28 \b .* \n }x; Return-MultiLevel-0.04/t/00-load.t0000644000175000017500000000030412401665626015553 0ustar maukemauke#!perl use Test::More tests => 1; BEGIN { use_ok( 'Return::MultiLevel' ); } diag( "Testing Return::MultiLevel $Return::MultiLevel::VERSION ($Return::MultiLevel::_backend), Perl $], $^X" ); Return-MultiLevel-0.04/t/basic.t0000644000175000017500000000124612401665637015510 0ustar maukemauke#!perl use Test::More tests => 5; use warnings FATAL => 'all'; use strict; use Return::MultiLevel qw(with_return); is with_return { my ($ret) = @_; 42 }, 42; is with_return { my ($ret) = @_; $ret->(42); 1 }, 42; is with_return { my ($ret) = @_; sub { $ret->($_[0]); 2 }->(42); 3 }, 42; sub foo { my ($f, $x) = @_; $f->('a', $x, 'b'); return 'x'; } is_deeply [with_return { my ($ret) = @_; sub { foo $ret, "$_[0] lo"; }->('hi'); () }], ['a', 'hi lo', 'b']; is_deeply [scalar with_return { my ($ret) = @_; sub { foo $ret, "$_[0] lo"; }->('hi'); () }], ['b']; Return-MultiLevel-0.04/t/nested.t0000644000175000017500000000074312401665644015710 0ustar maukemauke#!perl use Test::More tests => 1; use warnings FATAL => 'all'; use strict; use Return::MultiLevel qw(with_return); my @r; for my $i (1 .. 10) { push @r, with_return { my ($ret_outer) = @_; 100 + with_return { my ($ret_inner) = @_; sub { ($i % 2 ? $ret_outer : $ret_inner)->($i); 'bzzt1' }->(); 'bzzt2' } }; } is_deeply \@r, [1, 102, 3, 104, 5, 106, 7, 108, 9, 110];