Return-MultiLevel-0.05/0000755000175000017500000000000013155213677013775 5ustar maukemaukeReturn-MultiLevel-0.05/Makefile_PL_settings.plx0000644000175000017500000000122213155211573020540 0ustar maukemaukeuse strict; use warnings; return { NAME => 'Return::MultiLevel', AUTHOR => q{Lukas Mai }, MIN_PERL_VERSION => '5.8.0', CONFIGURE_REQUIRES => {}, BUILD_REQUIRES => {}, TEST_REQUIRES => { 'Test::Fatal' => 0, 'Test::More' => 0, }, PREREQ_PM => { 'Carp' => 0, 'Data::Munge' => '0.07', 'Exporter' => 0, 'parent' => 0, 'strict' => 0, 'warnings' => 0, }, RECOMMENDS => { 'Scope::Upper' => '0.29', }, DEVELOP_REQUIRES => { 'Test::Pod' => 1.22, }, REPOSITORY => [ github => 'mauke' ], }; Return-MultiLevel-0.05/README0000644000175000017500000000231213155213677014653 0ustar maukemaukeNAME Return::MultiLevel - return across multiple call levels INSTALLATION To download and install this module, use your favorite CPAN client, e.g. "cpan": cpan Return::MultiLevel Or "cpanm": cpanm Return::MultiLevel To do it manually, run the following commands (after downloading and unpacking the tarball): 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 . To see a list of open bugs, visit . To report a new bug, send an email to "bug-Return-MultiLevel [at] rt.cpan.org". 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 for more information. Return-MultiLevel-0.05/Changes0000644000175000017500000000143613155213540015261 0ustar maukemaukeRevision history for Return-MultiLevel 0.05 2017-09-10 - formally recommend Scope::Upper be installed in the distribution metadata - mention / link to bug tracker in module documentation 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.05/lib/0000755000175000017500000000000013155213676014542 5ustar maukemaukeReturn-MultiLevel-0.05/lib/Return/0000755000175000017500000000000013155213676016021 5ustar maukemaukeReturn-MultiLevel-0.05/lib/Return/MultiLevel.pm0000644000175000017500000001355313155213275020443 0ustar maukemaukepackage Return::MultiLevel; use warnings; use strict; our $VERSION = '0.05'; 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__ =encoding UTF-8 =for highlighter language=perl =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. =begin :README =head1 INSTALLATION To download and install this module, use your favorite CPAN client, e.g. L|cpan>: =for highlighter language=sh cpan Return::MultiLevel Or L|cpanm>: cpanm Return::MultiLevel To do it manually, run the following commands (after downloading and unpacking the tarball): perl Makefile.PL make make test make install =end :README =head1 SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the L|perldoc> command. =for highlighter language=sh perldoc Return::MultiLevel You can also look for information at L. To see a list of open bugs, visit L. To report a new bug, send an email to C. =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 L for more information. =cut Return-MultiLevel-0.05/META.yml0000644000175000017500000000150713155213676015250 0ustar maukemauke--- abstract: 'return across multiple call levels' author: - 'Lukas Mai ' build_requires: Test::Fatal: '0' Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' File::Find: '0' File::Spec: '0' strict: '0' warnings: '0' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.3, CPAN::Meta::Converter version 2.150010' 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 - xt recommends: Scope::Upper: '0.29' 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 version: '0.05' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Return-MultiLevel-0.05/xt/0000755000175000017500000000000013155213676014427 5ustar maukemaukeReturn-MultiLevel-0.05/xt/pod.t0000644000175000017500000000011313155211014015351 0ustar maukemauke#!perl use strict; use warnings; use Test::Pod 1.22; all_pod_files_ok(); Return-MultiLevel-0.05/META.json0000644000175000017500000000335313155213677015422 0ustar maukemauke{ "abstract" : "return across multiple call levels", "author" : [ "Lukas Mai " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.3, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Return-MultiLevel", "no_index" : { "directory" : [ "t", "inc", "xt" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0", "File::Find" : "0", "File::Spec" : "0", "strict" : "0", "warnings" : "0" } }, "develop" : { "requires" : { "Pod::Markdown" : "3.005", "Pod::Text" : "4.09", "Test::Pod" : "1.22" } }, "runtime" : { "recommends" : { "Scope::Upper" : "0.29" }, "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", "web" : "https://github.com/mauke/Return-MultiLevel" } }, "version" : "0.05", "x_serialization_backend" : "JSON::PP version 2.94" } Return-MultiLevel-0.05/Makefile.PL0000644000175000017500000001221413155210440015730 0ustar maukemaukeuse strict; use warnings; use ExtUtils::MakeMaker; use File::Spec (); use File::Find (); sub find_tests_recursively_in { my ($dir) = @_; -d $dir or die "$dir is not a directory"; my %seen; my $wanted = sub { /\.t\z/ or return; my $directories = (File::Spec->splitpath($File::Find::name))[1]; my $depth = grep $_ ne '', File::Spec->splitdir($directories); $seen{$depth} = 1; }; File::Find::find($wanted, $dir); join ' ', map { $dir . '/*' x $_ . '.t' } sort { $a <=> $b } keys %seen } $::MAINT_MODE = !-f 'META.yml'; my $settings_file = 'Makefile_PL_settings.plx'; my %settings = %{do "./$settings_file" or die "Internal error: can't do $settings_file: ", $@ || $!}; { $settings{depend}{Makefile} .= " $settings_file"; $settings{LICENSE} ||= 'perl'; $settings{PL_FILES} ||= {}; $settings{CONFIGURE_REQUIRES}{strict} ||= 0; $settings{CONFIGURE_REQUIRES}{warnings} ||= 0; $settings{CONFIGURE_REQUIRES}{'ExtUtils::MakeMaker'} ||= 0; $settings{CONFIGURE_REQUIRES}{'File::Find'} ||= 0; $settings{CONFIGURE_REQUIRES}{'File::Spec'} ||= 0; my $module_file = $settings{NAME}; $module_file =~ s!::!/!g; $module_file = "lib/$module_file.pm"; $settings{VERSION_FROM} ||= $module_file; $settings{ABSTRACT_FROM} ||= $module_file; $settings{test}{TESTS} ||= find_tests_recursively_in 't'; $settings{DISTNAME} ||= do { my $name = $settings{NAME}; $name =~ s!::!-!g; $name }; $settings{clean}{FILES} ||= "$settings{DISTNAME}-*"; $settings{dist}{COMPRESS} ||= 'gzip -9f'; $settings{dist}{SUFFIX} ||= '.gz'; my $version = $settings{VERSION} || MM->parse_version($settings{VERSION_FROM}); if ($version =~ s/-TRIAL[0-9]*\z//) { $settings{META_MERGE}{release_status} ||= 'unstable'; $settings{META_MERGE}{version} ||= $version; $settings{XS_VERSION} ||= $version; } $settings{META_MERGE}{'meta-spec'}{version} ||= 2; $settings{META_MERGE}{dynamic_config} ||= 0; push @{$settings{META_MERGE}{no_index}{directory}}, 'xt'; if (my $dev = delete $settings{DEVELOP_REQUIRES}) { @{$settings{META_MERGE}{prereqs}{develop}{requires}}{keys %$dev} = values %$dev; } if (my $rec = delete $settings{RECOMMENDS}) { @{$settings{META_MERGE}{prereqs}{runtime}{recommends}}{keys %$rec} = values %$rec; } if (my $sug = delete $settings{SUGGESTS}) { @{$settings{META_MERGE}{prereqs}{runtime}{suggests}}{keys %$sug} = values %$sug; } if (my $repo = delete $settings{REPOSITORY}) { if (ref($repo) eq 'ARRAY') { my ($type, @args) = @$repo; if ($type eq 'github') { my ($account, $project) = @args; $project ||= '%d'; $project =~ s{%(L?)(.)}{ my $x = $2 eq '%' ? '%' : $2 eq 'd' ? $settings{DISTNAME} : $2 eq 'm' ? $settings{NAME} : die "Internal error: unknown placeholder %$1$2"; $1 ? lc($x) : $x }seg; my $addr = "github.com/$account/$project"; $repo = { type => 'git', url => "git://$addr", web => "https://$addr", }; } else { die "Internal error: unknown REPOSITORY type '$type'"; } } ref($repo) eq 'HASH' or die "Internal error: REPOSITORY must be a hashref, not $repo"; @{$settings{META_MERGE}{resources}{repository}}{keys %$repo} = values %$repo; } } (do './maint/eumm-fixup.pl' || die $@ || $!)->(\%settings) if $::MAINT_MODE; (my $mm_version = ExtUtils::MakeMaker->VERSION) =~ tr/_//d; if ($mm_version < 6.63_03) { $settings{META_MERGE}{resources}{repository} = $settings{META_MERGE}{resources}{repository}{url} if $settings{META_MERGE}{resources} && $settings{META_MERGE}{resources}{repository} && $settings{META_MERGE}{resources}{repository}{url}; delete $settings{META_MERGE}{'meta-spec'}{version}; } elsif ($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; } { my $merge_key_into = sub { my ($target, $source) = @_; %{$settings{$target}} = (%{$settings{$target}}, %{delete $settings{$source}}); }; $merge_key_into->('BUILD_REQUIRES', 'TEST_REQUIRES') if $mm_version < 6.63_03; $merge_key_into->('CONFIGURE_REQUIRES', 'BUILD_REQUIRES') if $mm_version < 6.55_01; $merge_key_into->('PREREQ_PM', 'CONFIGURE_REQUIRES') if $mm_version < 6.51_03; } delete $settings{MIN_PERL_VERSION} if $mm_version < 6.47_01; delete $settings{META_MERGE} if $mm_version < 6.46; delete $settings{LICENSE} if $mm_version < 6.30_01; delete $settings{ABSTRACT_FROM} if $mm_version < 6.06_03; delete $settings{AUTHOR} if $mm_version < 6.06_03; WriteMakefile %settings; Return-MultiLevel-0.05/MANIFEST0000644000175000017500000000064713155213677015135 0ustar maukemaukeChanges lib/Return/MultiLevel.pm Makefile.PL Makefile_PL_settings.plx MANIFEST MANIFEST.SKIP t/00-load.t t/basic.t t/debug.t t/nested.t xt/pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README generated from Return::MultiLevel POD (added by maint/eumm-fixup.pl) Return-MultiLevel-0.05/t/0000755000175000017500000000000013155213676014237 5ustar maukemaukeReturn-MultiLevel-0.05/t/debug.t0000644000175000017500000000141012403111502015462 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.05/t/00-load.t0000644000175000017500000000030412401665626015554 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.05/t/basic.t0000644000175000017500000000124612401665637015511 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.05/t/nested.t0000644000175000017500000000074312401665644015711 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]; Return-MultiLevel-0.05/MANIFEST.SKIP0000644000175000017500000000026713155211116015662 0ustar maukemauke\.tar\.gz$ ^Build$ ^Return-MultiLevel- ^MANIFEST\.(?!SKIP$) ^MYMETA\. ^Makefile$ ^Makefile\.old$ ^MultiLevel\.(?:[iocs]|bs)$ ^\. ^_build ^blib ^cover_db$ ^pm_to_blib ^remote$ ^maint/