--- /dev/null
+blib*
+pm_to_blib*
+
+Makefile
+Makefile.old
+Build
+_build*
+
+*.tar.gz
+Scope-Upper-*
+
+core.*
+*.[co]
+*.so
+*.bs
+*.out
+*.def
+*.exp
+
+cover_db
+*.gcda
+*.gcov
+*.gcno
+
+Debian_CPANTS.txt
--- /dev/null
+Revision history for Scope-Upper
+
+0.01 2008-12-26 16:05 UTC
+ First version, released on an unsuspecting world.
+
--- /dev/null
+Changes
+MANIFEST
+Makefile.PL
+README
+Upper.xs
+lib/Scope/Upper.pm
+samples/tag.pl
+t/00-load.t
+t/01-import.t
+t/05-TOPLEVEL.t
+t/10-reap.t
+t/11-reap-level.t
+t/12-reap-block.t
+t/13-reap-ctl.t
+t/20-localize.t
+t/21-localize-level.t
+t/22-localize-block.t
+t/23-localize-ctl.t
+t/29-localize-target.t
+t/31-localize_elem-level.t
+t/32-localize_elem-block.t
+t/38-localize_elem-magic.t
+t/39-localize_elem-target.t
+t/90-boilerplate.t
+t/91-pod.t
+t/92-pod-coverage.t
+t/95-portability-files.t
+t/99-kwalitee.t
+t/lib/Scope/Upper/TestGenerator.pm
+META.yml Module meta-data (added by MakeMaker)
--- /dev/null
+--- #YAML:1.0
+name: Scope-Upper
+version: 0.01
+abstract: Act on upper scopes.
+author:
+ - Vincent Pit <perl@profvince.com>
+license: perl
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+requires:
+ XSLoader: 0
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.48
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+build_requires:
+ ExtUtils::MakeMaker: 0
+ Test::More: 0
--- /dev/null
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+my $BUILD_REQUIRES = {
+ 'ExtUtils::MakeMaker' => 0,
+ 'Test::More' => 0,
+};
+
+sub build_req {
+ my $tometa = ' >> $(DISTVNAME)/META.yml;';
+ my $build_req = 'echo "build_requires:" ' . $tometa;
+ foreach my $mod ( sort { lc $a cmp lc $b } keys %$BUILD_REQUIRES ) {
+ my $ver = $BUILD_REQUIRES->{$mod};
+ $build_req .= sprintf 'echo " %-30s %s" %s', "$mod:", $ver, $tometa;
+ }
+ return $build_req;
+}
+
+WriteMakefile(
+ NAME => 'Scope::Upper',
+ AUTHOR => 'Vincent Pit <perl@profvince.com>',
+ LICENSE => 'perl',
+ VERSION_FROM => 'lib/Scope/Upper.pm',
+ ABSTRACT_FROM => 'lib/Scope/Upper.pm',
+ PL_FILES => {},
+ PREREQ_PM => {
+ 'XSLoader' => 0,
+ },
+ dist => {
+ PREOP => 'pod2text lib/Scope/Upper.pm > $(DISTVNAME)/README; '
+ . build_req,
+ COMPRESS => 'gzip -9f', SUFFIX => 'gz'
+ },
+ clean => { FILES => 'Scope-Upper-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt' },
+);
--- /dev/null
+NAME
+ Scope::Upper - Act on upper scopes.
+
+VERSION
+ Version 0.01
+
+SYNOPSIS
+ package X;
+
+ use Scope::Upper qw/reap localize localize_elem/;
+
+ sub desc { shift->{desc} }
+
+ sub set_tag {
+ my ($desc) = @_;
+
+ # First localize $x so that it gets destroyed last
+ localize '$x' => bless({ desc => $desc }, __PACKAGE__) => 1;
+
+ reap sub {
+ my $pkg = caller;
+ my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope
+ print $x->desc . ": done\n";
+ } => 1;
+
+ localize_elem '%SIG', '__WARN__' => sub {
+ my $pkg = caller;
+ my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope
+ CORE::warn($x->desc . ': ' . join('', @_));
+ } => 1;
+ }
+
+ package Y;
+
+ {
+ X::set_tag('pie');
+ # $x is now a X object
+ warn 'what'; # warns "pie: what at ..."
+ ...
+ } # "pie: done" is printed
+
+DESCRIPTION
+ This module lets you defer actions that will take place when the control
+ flow returns into an upper scope. Currently, you can hook an upper scope
+ end, or localize variables and array/hash values in higher contexts.
+
+FUNCTIONS
+ "reap $callback, $level"
+ Add a destructor that calls $callback when the $level-th upper scope
+ ends, where 0 corresponds to the current scope.
+
+ "localize $what, $value, $level"
+ A "local" delayed to the time of first return into the $level-th upper
+ scope. $what can be :
+
+ * A glob, in which case $value can either be a glob or a reference.
+ "localize" follows then the same syntax as "local *x = $value". For
+ example, if $value is a scalar reference, then the "SCALAR" slot of
+ the glob will be set to $$value - just like "local *x = \1" sets $x
+ to 1.
+
+ * A string beginning with a sigil, representing the symbol to localize
+ and assign to. If the sigil is '$', then $value isn't dereferenced,
+ that is
+
+ localize '$x', \'foo' => 0;
+
+ will set $x to a reference to the string 'foo'. Other sigils behave
+ as if a glob was passed.
+
+ The symbol is resolved when the actual localization takes place and
+ not when "localize" is called. This means that
+
+ sub tag { localize '$x', $_[0] => 1; }
+
+ will localize in the caller's namespace.
+
+ "localize_elem $what, $key, $value, $level"
+ Similar to "localize" but for array and hash elements. If $what is a
+ glob, the slot to fill is determined from which type of reference $value
+ is ; otherwise it's inferred from the sigil. $key is either an array
+ index or a hash key, depending of which kind of variable you localize.
+
+ "TOPLEVEL"
+ Returns the level that currently represents the highest scope.
+
+EXPORT
+ The functions "reap", "localize", "localize_elem" and "TOPLEVEL" are
+ only exported on request, either individually or by the tags ':funcs'
+ and ':all'.
+
+DEPENDENCIES
+ XSLoader (standard since perl 5.006).
+
+SEE ALSO
+ Alias, Hook::Scope, Scope::Guard, Guard.
+
+AUTHOR
+ Vincent Pit, "<perl at profvince.com>", <http://www.profvince.com>.
+
+ You can contact me by mail or on "irc.perl.org" (vincent).
+
+BUGS
+ Please report any bugs or feature requests to "bug-scope-upper at
+ rt.cpan.org", or through the web interface at
+ <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Scope-Upper>. I will be
+ notified, and then you'll automatically be notified of progress on your
+ bug as I make changes.
+
+SUPPORT
+ You can find documentation for this module with the perldoc command.
+
+ perldoc Scope::Upper
+
+ACKNOWLEDGEMENTS
+ Inspired by Ricardo Signes.
+
+COPYRIGHT & LICENSE
+ Copyright 2008 Vincent Pit, all rights reserved.
+
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
--- /dev/null
+/* This file is part of the Scope::Upper Perl module.
+ * See http://search.cpan.org/dist/Scope-Upper/ */
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifndef SU_DEBUG
+# define SU_DEBUG 0
+#endif
+
+#ifndef STMT_START
+# define STMT_START do
+#endif
+
+#ifndef STMT_END
+# define STMT_END while (0)
+#endif
+
+#if SU_DEBUG
+# define SU_D(X) STMT_START X STMT_END
+#else
+# define SU_D(X)
+#endif
+
+#ifndef SvPV_const
+# define SvPV_const(S, L) SvPV(S, L)
+#endif
+
+#ifndef SvPV_nolen_const
+# define SvPV_nolen_const(S) SvPV_nolen(S)
+#endif
+
+#ifndef HvNAME_get
+# define HvNAME_get(H) HvNAME(H)
+#endif
+
+#ifndef gv_fetchpvn_flags
+# define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D))
+#endif
+
+#define SU_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
+
+typedef struct {
+ I32 depth;
+ I32 *origin;
+ void (*handler)(pTHX_ void *);
+} su_ud_common;
+
+#define SU_UD_DEPTH(U) (((su_ud_common *) (U))->depth)
+#define SU_UD_ORIGIN(U) (((su_ud_common *) (U))->origin)
+#define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler)
+
+#define SU_UD_FREE(U) do { \
+ if (SU_UD_ORIGIN(U)) Safefree(SU_UD_ORIGIN(U)); \
+ Safefree(U); \
+} while (0)
+
+typedef struct {
+ su_ud_common ci;
+ SV *cb;
+} su_ud_reap;
+
+STATIC void su_call(pTHX_ void *ud_) {
+ su_ud_reap *ud = (su_ud_reap *) ud_;
+#if SU_HAS_PERL(5, 10, 0)
+ I32 dieing = PL_op->op_type == OP_DIE;
+#endif
+
+ dSP;
+
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: @@@ call at %d (save is %d)\n",
+ ud, PL_scopestack_ix, PL_savestack_ix));
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ PUTBACK;
+
+ /* If cxstack_ix isn't incremented there, the eval context will be overwritten
+ * when the new sub scope will be created in call_sv. */
+
+#if SU_HAS_PERL(5, 10, 0)
+ if (dieing)
+ if (cxstack_ix < cxstack_max)
+ ++cxstack_ix;
+ else
+ cxstack_ix = Perl_cxinc(aTHX);
+#endif
+
+ call_sv(ud->cb, G_VOID);
+
+#if SU_HAS_PERL(5, 10, 0)
+ if (dieing && cxstack_ix > 0)
+ --cxstack_ix;
+#endif
+
+ SPAGAIN;
+ PUTBACK;
+
+ FREETMPS;
+ LEAVE;
+
+ SvREFCNT_dec(ud->cb);
+ SU_UD_FREE(ud);
+}
+
+STATIC void su_reap(pTHX_ void *ud) {
+#define su_reap(U) su_reap(aTHX_ (U))
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: === reap at %d (save is %d)\n",
+ ud, PL_scopestack_ix, PL_savestack_ix));
+ SAVEDESTRUCTOR_X(su_call, ud);
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: savestack is now at %d, base at %d\n",
+ ud, PL_savestack_ix,
+ PL_scopestack[PL_scopestack_ix]));
+}
+
+typedef struct {
+ su_ud_common ci;
+ SV *sv;
+ SV *val;
+ SV *elem;
+} su_ud_localize;
+
+/* Those two functions are courtesy of pp_hot.c:pp_helem */
+
+STATIC I32 su_hv_preeminent(pTHX_ HV *hv, SV *keysv) {
+#define su_hv_preeminent(H, K) su_hv_preeminent(aTHX_ (H), (K))
+ MAGIC *mg;
+ HV *stash;
+ return (!SvRMAGICAL(hv)
+ || mg_find((SV *) hv, PERL_MAGIC_env)
+ || ((mg = mg_find((SV *) hv, PERL_MAGIC_tied))
+ /* Try to preserve the existenceness of a tied hash
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise */
+ && (stash = SvSTASH(SvRV(SvTIED_obj((SV *) hv, mg))))
+ && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
+ && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
+ )
+ ) ? hv_exists_ent(hv, keysv, 0) : 1;
+}
+
+STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV **svp, I32 preeminent) {
+#define su_save_helem(H, K, S, P) su_save_helem(aTHX_ (H), (K), (S), (P))
+ if (HvNAME_get(hv) && isGV(*svp)) {
+ save_gp((GV *) *svp, 0);
+ return;
+ }
+ if (!preeminent) {
+ STRLEN keylen;
+ const char * const key = SvPV_const(keysv, keylen);
+ SAVEDELETE(hv, savepvn(key, keylen),
+ SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
+ } else {
+ save_helem(hv, keysv, svp);
+ }
+}
+
+STATIC void su_localize(pTHX_ void *ud_) {
+#define su_localize(U) su_localize(aTHX_ (U))
+ su_ud_localize *ud = (su_ud_localize *) ud_;
+ SV *sv = ud->sv;
+ SV *val = ud->val;
+ SV *elem = ud->elem;
+ GV *gv;
+ UV deref = 0;
+ svtype t = SVt_NULL;
+
+ if (SvTYPE(sv) >= SVt_PVGV) {
+ gv = (GV *) sv;
+ if (!SvROK(val))
+ goto assign;
+ t = SvTYPE(SvRV(val));
+ deref = 1;
+ } else {
+ STRLEN len, l;
+ const char *p = SvPV_const(sv, len), *s;
+ for (s = p, l = len; l > 0 && isSPACE(*s); ++s, --l) { }
+ if (!l) {
+ l = len;
+ s = p;
+ }
+ switch (*s) {
+ case '$': t = SVt_PV; break;
+ case '@': t = SVt_PVAV; break;
+ case '%': t = SVt_PVHV; break;
+ case '&': t = SVt_PVCV; break;
+ case '*': t = SVt_PVGV; break;
+ }
+ if (t == SVt_NULL) {
+ if (SvROK(val) && !sv_isobject(val)) {
+ t = SvTYPE(SvRV(val));
+ deref = 1;
+ } else {
+ t = SvTYPE(val);
+ }
+ } else {
+ ++s;
+ --l;
+ }
+ gv = gv_fetchpvn_flags(s, l, GV_ADDMULTI, SVt_PVGV);
+ }
+
+ SU_D({
+ SV *z = newSV_type(t);
+ PerlIO_printf(Perl_debug_log, "%p: === localize a %s at %d (save is %d)\n",
+ ud, sv_reftype(z, 0),
+ PL_scopestack_ix, PL_savestack_ix);
+ SvREFCNT_dec(z);
+ });
+
+ /* Inspired from Alias.pm */
+ switch (t) {
+ case SVt_PVAV:
+ if (elem) {
+ I32 idx = SvIV(elem);
+ AV *av = GvAV(gv);
+ SV **svp = av_fetch(av, idx, 1);
+ if (!*svp || *svp == &PL_sv_undef) croak(PL_no_aelem, idx);
+ save_aelem(av, idx, svp);
+ gv = (GV *) *svp;
+ goto maybe_deref;
+ } else
+ save_ary(gv);
+ break;
+ case SVt_PVHV:
+ if (elem) {
+ HV *hv = GvHV(gv);
+ I32 preeminent = hv ? su_hv_preeminent(hv, elem) : 0;
+ HE *he = hv_fetch_ent(hv, elem, 1, 0);
+ SV **svp = he ? &HeVAL(he) : NULL;
+ if (!svp || *svp == &PL_sv_undef) croak("Modification of non-creatable hash value attempted, subscript \"%s\"", SvPV_nolen_const(*svp));
+ su_save_helem(hv, elem, svp, preeminent);
+ gv = (GV *) *svp;
+ goto maybe_deref;
+ } else
+ save_hash(gv);
+ break;
+ case SVt_PVGV:
+ save_gp(gv, 1); /* hide previous entry in symtab */
+ break;
+ case SVt_PVCV:
+ SAVESPTR(GvCV(gv));
+ GvCV(gv) = NULL;
+ break;
+ default:
+ gv = (GV *) save_scalar(gv);
+maybe_deref:
+ if (deref)
+ val = SvRV(val);
+ break;
+ }
+
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: savestack is now at %d, base at %d\n",
+ ud, PL_savestack_ix,
+ PL_scopestack[PL_scopestack_ix]));
+
+assign:
+ SvSetMagicSV((SV *) gv, val);
+
+ SvREFCNT_dec(ud->elem);
+ SvREFCNT_dec(ud->val);
+ SvREFCNT_dec(ud->sv);
+ SU_UD_FREE(ud);
+}
+
+#if SU_DEBUG
+# ifdef DEBUGGING
+# define SU_CXNAME PL_block_type[CxTYPE(&cxstack[cxstack_ix])]
+# else
+# define SU_CXNAME "XXX"
+# endif
+#endif
+
+STATIC void su_pop(pTHX_ void *ud) {
+#define su_pop(U) su_pop(aTHX_ (U))
+ I32 depth, base, mark, *origin;
+ depth = SU_UD_DEPTH(ud);
+
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: --- pop %s at %d from %d to %d [%d]\n",
+ ud, SU_CXNAME,
+ PL_scopestack_ix, PL_savestack_ix,
+ PL_scopestack[PL_scopestack_ix],
+ depth));
+
+ origin = SU_UD_ORIGIN(ud);
+ mark = origin[depth];
+ base = origin[depth - 1];
+
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: clean from %d down to %d\n",
+ ud, mark, base));
+
+ if (base < mark) {
+ PL_savestack_ix = mark;
+ leave_scope(base);
+ }
+ PL_savestack_ix = base;
+ if (--depth > 0) {
+ SU_UD_DEPTH(ud) = depth;
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: save new destructor at %d [%d]\n",
+ ud, PL_savestack_ix, depth));
+ SAVEDESTRUCTOR_X(su_pop, ud);
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: pop end at at %d [%d]\n",
+ ud, PL_savestack_ix, depth));
+ } else {
+ SU_UD_HANDLER(ud)(aTHX_ ud);
+ }
+}
+
+STATIC I32 su_init(pTHX_ I32 level, void *ud, I32 size) {
+#define su_init(L, U, S) su_init(aTHX_ (L), (U), (S))
+ I32 i, depth = 0, *origin;
+ I32 cur, last, step;
+
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for level %d\n", ud, level));
+
+ for (i = 0; i < level; ++i) {
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix - i];
+ switch (CxTYPE(cx)) {
+#if SU_HAS_PERL(5, 11, 0)
+ case CXt_LOOP_FOR:
+ case CXt_LOOP_PLAIN:
+ case CXt_LOOP_LAZYSV:
+ case CXt_LOOP_LAZYIV:
+#else
+ case CXt_LOOP:
+#endif
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is loop\n", ud, i));
+ depth += 2;
+ break;
+ default:
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: cx %d is normal\n", ud, i));
+ depth++;
+ break;
+ }
+ }
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: depth is %d\n", ud, depth));
+
+ Newx(origin, depth + 1, I32);
+ origin[0] = PL_scopestack[PL_scopestack_ix - depth];
+ PL_scopestack[PL_scopestack_ix - depth] += size;
+ for (i = depth - 1; i >= 1; --i) {
+ I32 j = PL_scopestack_ix - i;
+ origin[depth - i] = PL_scopestack[j];
+ PL_scopestack[j] += 3;
+ }
+ origin[depth] = PL_savestack_ix;
+
+ SU_D({
+ PerlIO_printf(Perl_debug_log, "%p: d=%d s=%d x=%d c=%d o=%d\n", ud,
+ depth, 0, PL_scopestack_ix - 1, PL_savestack_ix, origin[depth]);
+ for (i = depth - 1; i >= 0; --i) {
+ I32 x = PL_scopestack_ix - depth + i;
+ PerlIO_printf(Perl_debug_log, "%p: d=%d s=%d x=%d c=%d o=%d\n", ud,
+ i, depth - i, x, PL_scopestack[x], origin[i]);
+ }
+ });
+
+ SU_UD_ORIGIN(ud) = origin;
+ SU_UD_DEPTH(ud) = depth;
+ return depth;
+}
+
+#define SU_GET_LEVEL(A) \
+ if (items > A) { \
+ SV *lsv = ST(A); \
+ if (SvOK(lsv)) \
+ level = SvUV(lsv); \
+ if (level < 0) \
+ XSRETURN(0); \
+ } \
+ if (level > cxstack_ix) \
+ level = cxstack_ix;
+
+/* --- XS ------------------------------------------------------------------ */
+
+MODULE = Scope::Upper PACKAGE = Scope::Upper
+
+PROTOTYPES: ENABLE
+
+SV *
+TOPLEVEL()
+PROTOTYPE:
+CODE:
+ RETVAL = newSViv(cxstack_ix);
+OUTPUT:
+ RETVAL
+
+void
+reap(SV *hook, ...)
+PROTOTYPE: &;$
+PREINIT:
+ I32 level = 0;
+ su_ud_reap *ud;
+CODE:
+ SU_GET_LEVEL(1);
+ Newx(ud, 1, su_ud_reap);
+ SU_UD_ORIGIN(ud) = NULL;
+ SU_UD_HANDLER(ud) = su_reap;
+ ud->cb = newSVsv(hook);
+ LEAVE;
+ if (level) {
+ I32 depth = su_init(level, ud, 3);
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: set original destructor at %d [%d]\n",
+ ud, PL_savestack_ix, depth));
+ SAVEDESTRUCTOR_X(su_pop, ud);
+ } else
+ su_reap(ud);
+ ENTER;
+
+void
+localize(SV *sv, SV *val, ...)
+PROTOTYPE: $$;$
+PREINIT:
+ I32 level = 0;
+ su_ud_localize *ud;
+CODE:
+ SU_GET_LEVEL(2);
+ Newx(ud, 1, su_ud_localize);
+ SU_UD_ORIGIN(ud) = NULL;
+ SU_UD_HANDLER(ud) = su_localize;
+ SvREFCNT_inc(sv);
+ ud->sv = sv;
+ ud->val = newSVsv(val);
+ ud->elem = NULL;
+ LEAVE;
+ if (level) {
+ I32 depth = su_init(level, ud, 3);
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: set original destructor at %d [%d]\n",
+ ud, PL_savestack_ix, depth));
+ SAVEDESTRUCTOR_X(su_pop, ud);
+ } else
+ su_localize(ud);
+ ENTER;
+
+void
+localize_elem(SV *sv, SV *elem, SV *val, ...)
+PROTOTYPE: $$$;$
+PREINIT:
+ I32 level = 0;
+ su_ud_localize *ud;
+CODE:
+ SU_GET_LEVEL(3);
+ Newx(ud, 1, su_ud_localize);
+ SU_UD_ORIGIN(ud) = NULL;
+ SU_UD_HANDLER(ud) = su_localize;
+ SvREFCNT_inc(sv);
+ ud->sv = sv;
+ ud->val = newSVsv(val);
+ SvREFCNT_inc(elem);
+ ud->elem = elem;
+ LEAVE;
+ if (level) {
+ I32 depth = su_init(level, ud, 4);
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: set original destructor at %d [%d]\n",
+ ud, PL_savestack_ix, depth));
+ SAVEDESTRUCTOR_X(su_pop, ud);
+ } else
+ su_localize(ud);
+ ENTER;
+
--- /dev/null
+package Scope::Upper;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Scope::Upper - Act on upper scopes.
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION;
+BEGIN {
+ $VERSION = '0.01';
+}
+
+=head1 SYNOPSIS
+
+ package X;
+
+ use Scope::Upper qw/reap localize localize_elem/;
+
+ sub desc { shift->{desc} }
+
+ sub set_tag {
+ my ($desc) = @_;
+
+ # First localize $x so that it gets destroyed last
+ localize '$x' => bless({ desc => $desc }, __PACKAGE__) => 1;
+
+ reap sub {
+ my $pkg = caller;
+ my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope
+ print $x->desc . ": done\n";
+ } => 1;
+
+ localize_elem '%SIG', '__WARN__' => sub {
+ my $pkg = caller;
+ my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope
+ CORE::warn($x->desc . ': ' . join('', @_));
+ } => 1;
+ }
+
+ package Y;
+
+ {
+ X::set_tag('pie');
+ # $x is now a X object
+ warn 'what'; # warns "pie: what at ..."
+ ...
+ } # "pie: done" is printed
+
+=head1 DESCRIPTION
+
+This module lets you defer actions that will take place when the control flow returns into an upper scope.
+Currently, you can hook an upper scope end, or localize variables and array/hash values in higher contexts.
+
+=head1 FUNCTIONS
+
+=cut
+
+BEGIN {
+ require XSLoader;
+ XSLoader::load(__PACKAGE__, $VERSION);
+}
+
+=head2 C<reap $callback, $level>
+
+Add a destructor that calls C<$callback> when the C<$level>-th upper scope ends, where C<0> corresponds to the current scope.
+
+=head2 C<localize $what, $value, $level>
+
+A C<local> delayed to the time of first return into the C<$level>-th upper scope.
+C<$what> can be :
+
+=over 4
+
+=item *
+
+A glob, in which case C<$value> can either be a glob or a reference.
+L</localize> follows then the same syntax as C<local *x = $value>.
+For example, if C<$value> is a scalar reference, then the C<SCALAR> slot of the glob will be set to C<$$value> - just like C<local *x = \1> sets C<$x> to C<1>.
+
+=item *
+
+A string beginning with a sigil, representing the symbol to localize and assign to.
+If the sigil is C<'$'>, then C<$value> isn't dereferenced, that is
+
+ localize '$x', \'foo' => 0;
+
+will set C<$x> to a reference to the string C<'foo'>.
+Other sigils behave as if a glob was passed.
+
+The symbol is resolved when the actual localization takes place and not when C<localize> is called.
+This means that
+
+ sub tag { localize '$x', $_[0] => 1; }
+
+will localize in the caller's namespace.
+
+=back
+
+=head2 C<localize_elem $what, $key, $value, $level>
+
+Similar to L</localize> but for array and hash elements.
+If C<$what> is a glob, the slot to fill is determined from which type of reference C<$value> is ; otherwise it's inferred from the sigil.
+C<$key> is either an array index or a hash key, depending of which kind of variable you localize.
+
+=head2 C<TOPLEVEL>
+
+Returns the level that currently represents the highest scope.
+
+=head1 EXPORT
+
+The functions L</reap>, L</localize>, L</localize_elem> and L</TOPLEVEL> are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>.
+
+=cut
+
+use base qw/Exporter/;
+
+our @EXPORT = ();
+our %EXPORT_TAGS = (
+ funcs => [ qw/reap localize localize_elem TOPLEVEL/ ],
+);
+our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
+$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
+
+=head1 DEPENDENCIES
+
+L<XSLoader> (standard since perl 5.006).
+
+=head1 SEE ALSO
+
+L<Alias>, L<Hook::Scope>, L<Scope::Guard>, L<Guard>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on C<irc.perl.org> (vincent).
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-scope-upper at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Scope-Upper>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Scope::Upper
+
+=head1 ACKNOWLEDGEMENTS
+
+Inspired by Ricardo Signes.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2008 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1; # End of Scope::Upper
--- /dev/null
+#!perl
+
+package X;
+
+use strict;
+use warnings;
+
+use blib;
+
+use Scope::Upper qw/reap localize localize_elem/;
+
+sub desc { shift->{desc} }
+
+sub set_tag {
+ my ($desc) = @_;
+
+ # First localize $x so that it gets destroyed last
+ localize '$x' => bless({ desc => $desc }, __PACKAGE__) => 1;
+
+ reap sub {
+ my $pkg = caller;
+ my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope
+ print $x->desc . ": done\n";
+ } => 1;
+
+ localize_elem '%SIG', '__WARN__' => sub {
+ my $pkg = caller;
+ my $x = do { no strict 'refs'; ${$pkg.'::x'} }; # Get the $x in the scope
+ CORE::warn($x->desc . ': ' . join('', @_));
+ } => 1;
+}
+
+package main;
+
+use strict;
+use warnings;
+
+{
+ X::set_tag('pie');
+ # $x is now a X object
+ warn 'what'; # warns "pie: what"
+} # "pie: done" is printed
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'Scope::Upper' );
+}
+
+diag( "Testing Scope::Upper $Scope::Upper::VERSION, Perl $], $^X" );
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+require Scope::Upper;
+
+for (qw/reap localize localize_elem TOPLEVEL/) {
+ eval { Scope::Upper->import($_) };
+ is($@, '', 'import ' . $_);
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+
+use Scope::Upper qw/TOPLEVEL/;
+
+is TOPLEVEL, 0, 'main is 0';
+
+{
+ is TOPLEVEL, 1, '{ 1 }';
+}
+
+do {
+ is TOPLEVEL, 1, 'do { 1 }';
+};
+
+eval {
+ is TOPLEVEL, 1, 'eval { 1 }';
+};
+
+eval q[
+ is TOPLEVEL, 1, 'eval "1"';
+];
+
+do {
+ is TOPLEVEL, 1, 'do { 1 } while (0)';
+} while (0);
+
+sub {
+ is TOPLEVEL, 1, 'sub { 1 }';
+}->();
+
+for (1) {
+ is TOPLEVEL, 1, 'for () { 1 }';
+}
+
+do {
+ eval {
+ do {
+ sub {
+ eval q[
+ {
+ is TOPLEVEL, 6, 'all'
+ }
+ ];
+ }->();
+ }
+ };
+} while (0);
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 4 + 8 + 8 + 18 + 4 + 8 + 6 + 11 + 5 + 17;
+
+use Scope::Upper qw/reap/;
+
+my $x;
+
+sub add { local $_; my $y = $_[1]; reap sub { $x += $y }, $_[0] + 1 }
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ {
+ add(0, 1);
+ is($x, 0, '1 didn\'t run');
+ }
+ is($x, 1, '1 ran');
+}
+is($x, 1, 'end');
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ local $_ = 3;
+ is($_, 3, '$_ has the right value');
+ {
+ add(0, 1);
+ is($_, 3, '$_ has the right value');
+ local $_ = 7;
+ is($_, 7, '$_ has the right value');
+ is($x, 0, '1 didn\'t run');
+ }
+ is($x, 1, '1 ran');
+ is($_, 3, '$_ has the right value');
+}
+is($x, 1, 'end');
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ {
+ add(0, 1);
+ is($x, 0, '1 didn\'t run');
+ {
+ add(0, 2);
+ is($x, 0, '1 and 2 didn\'t run');
+ }
+ is($x, 2, '1 didn\'t run, 2 ran');
+ {
+ add(0, 4);
+ is($x, 2, '1 and 3 didn\'t run, 2 ran');
+ }
+ is($x, 6, '1 didn\'t run, 2 and 3 ran');
+ }
+ is($x, 7, '1, 2 and 3 ran');
+}
+is($x, 7, 'end');
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ local $_ = 3;
+ is($_, 3, '$_ has the right value');
+ {
+ add(0, 1);
+ is($_, 3, '$_ has the right value');
+ local $_ = 5;
+ is($x, 0, '1 didn\'t run');
+ is($_, 5, '$_ has the right value');
+ {
+ add(0, 2);
+ is($_, 5, '$_ has the right value');
+ local $_ = 7;
+ is($_, 7, '$_ has the right value');
+ is($x, 0, '1 and 2 didn\'t run');
+ }
+ is($x, 2, '1 didn\'t run, 2 ran');
+ is($_, 5, '$_ has the right value');
+ {
+ local $_ = 9;
+ is($_, 9, '$_ has the right value');
+ add(0, 4);
+ local $_ = 11;
+ is($_, 11, '$_ has the right value');
+ is($x, 2, '1 and 3 didn\'t run, 2 ran');
+ }
+ is($x, 6, '1 didn\'t run, 2 and 3 ran');
+ is($_, 5, '$_ has the right value');
+ }
+ is($x, 7, '1, 2 and 3 ran');
+ is($_, 3, '$_ has the right value');
+}
+is($x, 7, 'end');
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ {
+ add(0, 1);
+ add(0, 2);
+ is($x, 0, '1 and 2 didn\'t run');
+ }
+ is($x, 3, '1 and 2 ran');
+}
+is($x, 3, 'end');
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ local $_ = 3;
+ {
+ local $_ = 5;
+ add(0, 1);
+ is($_, 5, '$_ has the right value');
+ local $_ = 7;
+ add(0, 2);
+ is($_, 7, '$_ has the right value');
+ is($x, 0, '1 and 2 didn\'t run');
+ local $_ = 9;
+ is($_, 9, '$_ has the right value');
+ }
+ is($x, 3, '1 and 2 ran');
+ is($_, 3, '$_ has the right value');
+}
+is($x, 3, 'end');
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ {
+ {
+ {
+ add(2, 1);
+ is($x, 0, '1 didn\'t run');
+ }
+ is($x, 0, '1 didn\'t run');
+ }
+ is($x, 0, '1 didn\'t run');
+ }
+ is($x, 1, '1 ran');
+}
+is($x, 1, 'end');
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ {
+ {
+ add(1, 1);
+ is($x, 0, '1 didn\'t run');
+ }
+ is($x, 0, '1 didn\'t run');
+ }
+ is($x, 1, '1 ran');
+ {
+ {
+ {
+ add(2, 2);
+ is($x, 1, '2 didn\'t run');
+ }
+ is($x, 1, '2 didn\'t run');
+ {
+ add(1, 4);
+ is($x, 1, '2 and 3 didn\'t run');
+ }
+ is($x, 1, '2 and 3 didn\'t run');
+ }
+ is($x, 5, '2 didn\'t run, 3 ran');
+ }
+ is($x, 7, '2 and 3 ran');
+}
+is($x, 7, 'end');
+
+sub bleh { add(1, 2); }
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ {
+ add(0, 1);
+ is($x, 0, '1 didn\'t run');
+ bleh();
+ is($x, 0, '1 didn\'t run');
+ }
+ is($x, 3, '1 ran');
+}
+is($x, 3, 'end');
+
+sub bar {
+ is($_, 7, '$_ has the right value');
+ local $_ = 9;
+ add(2, 4);
+ is($_, 9, '$_ has the right value');
+ add(3, 8);
+ is($_, 9, '$_ has the right value');
+}
+
+sub foo {
+ local $_ = 7;
+ add(0, 2);
+ is($_, 7, '$_ has the right value');
+ is($x, 0, '1, 2 didn\'t run');
+ bar();
+ is($x, 0, '1, 2, 3, 4 didn\'t run');
+ is($_, 7, '$_ has the right value');
+ add(1, 16);
+ is($_, 7, '$_ has the right value');
+}
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ local $_ = 3;
+ add(0, 1);
+ is($_, 3, '$_ has the right value');
+ {
+ local $_ = 5;
+ is($_, 5, '$_ has the right value');
+ is($x, 0, '1 didn\'t run');
+ {
+ foo();
+ is($x, 2, '1, 3, 4 and 5 didn\'t run, 2 ran');
+ is($_, 5, '$_ has the right value');
+ }
+ is($x, 22, '1 and 4 didn\'t run, 2, 3 and 5 ran');
+ }
+ is($x, 30, '1 didn\'t run, 2, 3, 4 and 5 ran');
+}
+is($x, 31, 'end');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use Scope::Upper qw/reap/;
+
+use lib 't/lib';
+use Scope::Upper::TestGenerator;
+
+local $Scope::Upper::TestGenerator::call = sub {
+ my ($height, $level, $i) = @_;
+ return [ "reap \\&check => $level;\n" ];
+};
+
+local $Scope::Upper::TestGenerator::test = sub {
+ my ($height, $level, $i) = @_;
+ my $j = $i < $height - $level ? 1 : 'undef';
+ return "is(\$main::y, $j, 'y h=$height, l=$level, i=$i');\n";
+};
+
+our ($x, $y, $testcase);
+
+sub check { $y = 0 unless defined $y; ++$y }
+
+{
+ no warnings 'redefine';
+ *is = sub ($$;$) {
+ my ($a, $b, $desc) = @_;
+ if (defined $testcase
+ and (defined $b) ? (not defined $a or $a != $b) : defined $a) {
+ diag <<DIAG;
+=== This testcase failed ===
+$testcase
+==== vvvvv Errors vvvvvv ===
+DIAG
+ undef $testcase;
+ }
+ Test::More::is($a, $b, $desc);
+ }
+}
+
+for my $level (0 .. 4) {
+ for my $height ($level + 1 .. $level + 2) {
+ my $tests = Scope::Upper::TestGenerator::gen($height, $level);
+ for (@$tests) {
+ $testcase = $_;
+ $x = $y = undef;
+ eval;
+ diag $@ if $@;
+ }
+ }
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use Scope::Upper qw/reap/;
+
+use lib 't/lib';
+use Scope::Upper::TestGenerator;
+
+local $Scope::Upper::TestGenerator::call = sub {
+ my ($height, $level, $i) = @_;
+ return [ "reap \\&check => $level;\n" ];
+};
+
+local $Scope::Upper::TestGenerator::test = sub {
+ my ($height, $level, $i, $x) = @_;
+ my $j = $i < $height - $level ? 0 : (defined $x ? $x : 'undef');
+ return "is(\$x, $j, 'x h=$height, l=$level, i=$i');\n";
+};
+
+local $Scope::Upper::TestGenerator::local = sub {
+ my ($height, $level, $i, $x) = @_;
+ return $i == $height - $level ? "\$x = $x;\n" : "local \$x = $x;\n";
+};
+
+local $Scope::Upper::TestGenerator::testlocal = sub { '' };
+
+local $Scope::Upper::TestGenerator::allblocks = 1;
+
+our ($x, $testcase);
+
+sub check { $x = (defined $x) ? ($x ? 0 : $x . 'x') : 0 }
+
+{
+ no warnings 'redefine';
+ *is = sub ($$;$) {
+ my ($a, $b, $desc) = @_;
+ if (defined $testcase
+ and (defined $b) ? (not defined $a or $a != $b) : defined $a) {
+ diag <<DIAG;
+=== This testcase failed ===
+$testcase
+==== vvvvv Errors vvvvvv ===
+DIAG
+ undef $testcase;
+ }
+ Test::More::is($a, $b, $desc);
+ }
+}
+
+for my $level (0 .. 1) {
+ my $height = $level + 1;
+ my $tests = Scope::Upper::TestGenerator::gen($height, $level);
+ for (@$tests) {
+ $testcase = $_;
+ $x = undef;
+ eval;
+ diag $@ if $@;
+ }
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 28;
+
+use Scope::Upper qw/reap/;
+
+our ($x, $y);
+
+sub check { ++$y }
+
+{
+ local $x = 1;
+ {
+ local $x = 2;
+ {
+ reap \&check => 1;
+ }
+ is $x, 2, 'goto 1 [not yet - x]';
+ is $y, undef, 'goto 1 [not yet - y]';
+ {
+ local $x = 3;
+ goto OVER1;
+ }
+ }
+ $y = 0;
+OVER1:
+ is $x, 1, 'goto 1 [ok - x]';
+ is $y, 1, 'goto 1 [ok - y]';
+}
+
+$y = undef;
+{
+ local $x = 1;
+ {
+ local $x = 2;
+ {
+ local $x = 3;
+ {
+ reap \&check => 2;
+ }
+ is $x, 3, 'goto 2 [not yet - x]';
+ is $y, undef, 'goto 2 [not yet - y]';
+ {
+ local $x = 4;
+ goto OVER2;
+ }
+ }
+ }
+ $y = 0;
+OVER2:
+ is $x, 1, 'goto 2 [ok - x]';
+ is $y, 1, 'goto 2 [ok - y]';
+}
+
+$y = undef;
+{
+ local $x = 1;
+ {
+ eval {
+ local $x = 2;
+ {
+ {
+ local $x = 3;
+ reap \&check => 3;
+ is $x, 3, 'die - reap outside eval [not yet 1 - x]';
+ is $y, undef, 'die - reap outside eval [not yet 1 - y]';
+ }
+ is $x, 2, 'die - reap outside eval [not yet 2 - x]';
+ is $y, undef, 'die - reap outside eval [not yet 2 - y]';
+ die;
+ }
+ };
+ is $x, 1, 'die - reap outside eval [not yet 3 - x]';
+ is $y, undef, 'die - reap outside eval [not yet 3 - y]';
+ } # should trigger here
+ is $x, 1, 'die - reap outside eval [ok - x]';
+ is $y, 1, 'die - reap outside eval [ok - y]';
+}
+
+$y = undef;
+{
+ local $x = 1;
+ eval {
+ local $x = 2;
+ {
+ {
+ local $x = 3;
+ reap \&check => 2;
+ is $x, 3, 'die - reap at eval [not yet 1 - x]';
+ is $y, undef, 'die - reap at eval [not yet 1 - y]';
+ }
+ is $x, 2, 'die - reap at eval [not yet 2 - x]';
+ is $y, undef, 'die - reap at eval [not yet 2 - y]';
+ die;
+ }
+ }; # should trigger here
+ is $x, 1, 'die - reap at eval [ok - x]';
+ is $y, 1, 'die - reap at eval [ok - y]';
+}
+
+$y = undef;
+{
+ local $x = 1;
+ eval {
+ local $x = 2;
+ {
+ {
+ local $x = 3;
+ reap \&check => 1;
+ is $x, 3, 'die - reap inside eval [not yet 1 - x]';
+ is $y, undef, 'die - reap inside eval [not yet 1 - y]';
+ }
+ is $x, 2, 'die - reap inside eval [not yet 2 - x]';
+ is $y, undef, 'die - reap inside eval [not yet 2 - y]';
+ die;
+ } # should trigger here
+ };
+ is $x, 1, 'die - reap inside eval [ok - x]';
+ is $y, 1, 'die - reap inside eval [ok - y]';
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 4 + 10 + 6 + 5 + 6;
+
+use Scope::Upper qw/localize/;
+
+our $x;
+
+sub loc { local $x; my $y = $_[1]; localize '$x', $y, $_[0] + 1 }
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ local $x = 7;
+ {
+ local $x = 8;
+ loc(0, 1);
+ is($x, 1, 'localized to 1');
+ }
+ is($x, 7, 'no longer localized');
+}
+is($x, 0, 'end');
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ local $x = 7;
+ {
+ local $x = 8;
+ loc(1, 1);
+ is($x, 8, 'not localized');
+ local $x = 9;
+ is($x, 9, 'not localized');
+ }
+ is($x, 1, 'localized to 1');
+ {
+ is($x, 1, 'localized to 1');
+ {
+ is($x, 1, 'localized to 1');
+ local $x = 10;
+ is($x, 10, 'localized to undef');
+ }
+ is($x, 1, 'localized to 1');
+ }
+ is($x, 1, 'localized to 1');
+}
+is($x, 0, 'end');
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ local $x = 7;
+ {
+ local $x = 8;
+ {
+ local $x = 9;
+ {
+ local $x = 10;
+ loc(2, 1);
+ is($x, 10, 'not localized');
+ }
+ is($x, 9, 'not localized');
+ }
+ is($x, 1, 'localized to 1');
+ }
+ is($x, 7, 'no longer localized');
+}
+is($x, 0, 'end');
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ local $x = 8;
+ {
+ {
+ local $x = 8;
+ loc(2, 1);
+ is($x, 8, 'not localized');
+ }
+ loc(0, 2);
+ is($x, 2, 'localized to 2');
+ }
+ is($x, 1, 'localized to 1');
+}
+is($x, 0, 'end');
+
+$x = 0;
+{
+ is($x, 0, 'start');
+ local $x;
+ {
+ {
+ loc(2, 1);
+ is($x, undef, 'not localized');
+ local $x;
+ loc(1, 2);
+ is($x, undef, 'not localized');
+ }
+ is($x, 2, 'localized to 2');
+ }
+ is($x, 1, 'localized to 1');
+}
+is($x, 0, 'end');
+
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use Scope::Upper qw/localize/;
+
+use lib 't/lib';
+use Scope::Upper::TestGenerator;
+
+local $Scope::Upper::TestGenerator::call = sub {
+ my ($height, $level, $i) = @_;
+ return [ "localize '\$main::y' => 1 => $level;\n" ];
+};
+
+local $Scope::Upper::TestGenerator::test = sub {
+ my ($height, $level, $i) = @_;
+ my $j = ($i == $height - $level) ? 1 : 'undef';
+ return "is(\$main::y, $j, 'y h=$height, l=$level, i=$i');\n";
+};
+
+our ($x, $y, $testcase);
+
+{
+ no warnings 'redefine';
+ *is = sub ($$;$) {
+ my ($a, $b, $desc) = @_;
+ if (defined $testcase
+ and (defined $b) ? (not defined $a or $a != $b) : defined $a) {
+ diag <<DIAG;
+=== This testcase failed ===
+$testcase
+==== vvvvv Errors vvvvvv ===
+DIAG
+ undef $testcase;
+ }
+ Test::More::is($a, $b, $desc);
+ }
+}
+
+for my $level (0 .. 4) {
+ for my $height ($level + 1 .. $level + 2) {
+ my $tests = Scope::Upper::TestGenerator::gen($height, $level);
+ for (@$tests) {
+ $testcase = $_;
+ $x = $y = undef;
+ eval;
+ diag $@ if $@;
+ }
+ }
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use Scope::Upper qw/localize/;
+
+use lib 't/lib';
+use Scope::Upper::TestGenerator;
+
+local $Scope::Upper::TestGenerator::call = sub {
+ my ($height, $level, $i) = @_;
+ return [ "localize '\$x' => 0 => $level;\n" ];
+};
+
+local $Scope::Upper::TestGenerator::test = sub {
+ my ($height, $level, $i, $x) = @_;
+ my $j = ($i == $height - $level) ? 0 : (defined $x ? $x : 'undef');
+ return "is(\$x, $j, 'x h=$height, l=$level, i=$i');\n";
+};
+
+local $Scope::Upper::TestGenerator::testlocal = sub { '' };
+
+local $Scope::Upper::TestGenerator::allblocks = 1;
+
+our ($x, $testcase);
+
+{
+ no warnings 'redefine';
+ *is = sub ($$;$) {
+ my ($a, $b, $desc) = @_;
+ if (defined $testcase
+ and (defined $b) ? (not defined $a or $a != $b) : defined $a) {
+ diag <<DIAG;
+=== This testcase failed ===
+$testcase
+==== vvvvv Errors vvvvvv ===
+DIAG
+ undef $testcase;
+ }
+ Test::More::is($a, $b, $desc);
+ }
+}
+
+for my $level (0 .. 1) {
+ my $height = $level + 1;
+ my $tests = Scope::Upper::TestGenerator::gen($height, $level);
+ for (@$tests) {
+ $testcase = $_;
+ $x = undef;
+ eval;
+ diag $@ if $@;
+ }
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 28;
+
+use Scope::Upper qw/localize/;
+
+our ($x, $y);
+
+{
+ local $x = 1;
+ {
+ local $x = 2;
+ {
+ localize '$y' => 1 => 2;
+ }
+ is $x, 2, 'goto 1 [not yet - x]';
+ is $y, undef, 'goto 1 [not yet - y]';
+ {
+ local $x = 3;
+ goto OVER1;
+ }
+ }
+ $y = 0;
+OVER1:
+ is $x, 1, 'goto 1 [ok - x]';
+ is $y, 1, 'goto 1 [ok - y]';
+}
+
+$y = undef;
+{
+ local $x = 1;
+ {
+ local $x = 2;
+ {
+ local $x = 3;
+ {
+ localize '$y' => 1 => 3;
+ }
+ is $x, 3, 'goto 2 [not yet - x]';
+ is $y, undef, 'goto 2 [not yet - y]';
+ {
+ local $x = 4;
+ goto OVER2;
+ }
+ }
+ }
+ $y = 0;
+OVER2:
+ is $x, 1, 'goto 2 [ok - x]';
+ is $y, 1, 'goto 2 [ok - y]';
+}
+
+$y = undef;
+{
+ local $x = 1;
+ {
+ eval {
+ local $x = 2;
+ {
+ {
+ local $x = 3;
+ localize '$y' => 1 => 4;
+ is $x, 3, 'die - reap outside eval [not yet 1 - x]';
+ is $y, undef, 'die - reap outside eval [not yet 1 - y]';
+ }
+ is $x, 2, 'die - reap outside eval [not yet 2 - x]';
+ is $y, undef, 'die - reap outside eval [not yet 2 - y]';
+ die;
+ }
+ };
+ is $x, 1, 'die - reap outside eval [not yet 3 - x]';
+ is $y, undef, 'die - reap outside eval [not yet 3 - y]';
+ } # should trigger here
+ is $x, 1, 'die - reap outside eval [ok - x]';
+ is $y, 1, 'die - reap outside eval [ok - y]';
+}
+
+$y = undef;
+{
+ local $x = 1;
+ eval {
+ local $x = 2;
+ {
+ {
+ local $x = 3;
+ localize '$y' => 1 => 3;
+ is $x, 3, 'die - reap at eval [not yet 1 - x]';
+ is $y, undef, 'die - reap at eval [not yet 1 - y]';
+ }
+ is $x, 2, 'die - reap at eval [not yet 2 - x]';
+ is $y, undef, 'die - reap at eval [not yet 2 - y]';
+ die;
+ }
+ }; # should trigger here
+ is $x, 1, 'die - reap at eval [ok - x]';
+ is $y, 1, 'die - reap at eval [ok - y]';
+}
+
+$y = undef;
+{
+ local $x = 1;
+ eval {
+ local $x = 2;
+ {
+ {
+ local $x = 3;
+ localize '$y' => 1 => 2;
+ is $x, 3, 'die - reap inside eval [not yet 1 - x]';
+ is $y, undef, 'die - reap inside eval [not yet 1 - y]';
+ }
+ is $x, 2, 'die - reap inside eval [not yet 2 - x]';
+ is $y, undef, 'die - reap inside eval [not yet 2 - y]';
+ die;
+ } # should trigger here
+ };
+ is $x, 1, 'die - reap inside eval [ok - x]';
+ is $y, undef, 'die - reap inside eval [ok - y]';
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 50;
+
+use Scope::Upper qw/localize/;
+
+# Scalars
+
+our $x;
+
+{
+ local $x = 2;
+ {
+ localize *x, \1, 0;
+ is $x, 1, 'localize *x, \1, 0 [ok]';
+ }
+ is $x, 2, 'localize *x, \1, 0 [end]';
+}
+
+sub _t { shift->{t} }
+
+{
+ local $x;
+ {
+ localize *x, \bless({ t => 1 }, 'main'), 0;
+ is ref($x), 'main', 'localize *x, obj, 0 [ref]';
+ is $x->_t, 1, 'localize *x, obj, 0 [meth]';
+ }
+ is $x, undef, 'localize *x, obj, 0 [end]';
+}
+
+{
+ local $x = 2;
+ {
+ local $x = 3;
+ localize *x, 1, 0;
+ is $x, undef, 'localize *x, 1, 0 [ok]';
+ }
+ is $x, $] < 5.008009 ? undef : 2, 'localize *x, 1, 0 [end]';
+}
+undef *x;
+
+{
+ local $x = 7;
+ {
+ localize '$x', 2, 0;
+ is $x, 2, 'localize "$x", 2, 0 [ok]';
+ }
+ is $x, 7, 'localize "$x", 2, 0 [end]';
+}
+
+{
+ local $x = 8;
+ {
+ localize ' $x', 3, 0;
+ is $x, 3, 'localize " $x", 3, 0 [ok]';
+ }
+ is $x, 8, 'localize " $x", 3, 0 [end]';
+}
+
+{
+ no strict 'refs';
+ local ${''} = 9;
+ {
+ localize '$', 4, 0;
+ is ${''}, 4, 'localize "$", 4, 0 [ok]';
+ }
+ is ${''}, 9, 'localize "$", 4, 0 [end]';
+}
+
+{
+ no strict 'refs';
+ local ${''} = 10;
+ {
+ localize '', 5, 0;
+ is ${''}, 5, 'localize "", 4, 0 [ok]';
+ }
+ is ${''}, 10, 'localize "", 4, 0 [end]';
+}
+
+{
+ local $x = 2;
+ {
+ localize 'x', \1, 0;
+ is $x, 1, 'localize "x", \1, 0 [ok]';
+ }
+ is $x, 2, 'localize "x", \1, 0 [end]';
+}
+
+{
+ local $x = 4;
+ {
+ localize 'x', 3, 0;
+ is $x, 3, 'localize "x", 3, 0 [ok]';
+ }
+ is $x, 4, 'localize "x", 3, 0 [end]';
+}
+
+{
+ local $x;
+ {
+ localize 'x', bless({ t => 2 }, 'main'), 0;
+ is ref($x), 'main', 'localize "x", obj, 0 [ref]';
+ is $x->_t, 2, 'localize "x", obj, 0 [meth]';
+ }
+ is $x, undef, 'localize "x", obj, 0 [end]';
+}
+
+sub callthrough (*$) {
+ my ($what, $val) = @_;
+ if (ref $what) {
+ $what = $$what;
+ $val = eval "\\$val";
+ }
+ local $x = 'x';
+ localize $what, $val, 1;
+ is $x, 'x', 'localize callthrough [not yet]';
+}
+
+{
+ package Scope::Upper::Test::Mock1;
+ our $x;
+ {
+ main::callthrough(*x, 4);
+ Test::More::is($x, 4, 'localize glob [ok - SUTM1]');
+ Test::More::is($main::x, undef, 'localize glob [ok - main]');
+ }
+}
+
+{
+ package Scope::Upper::Test::Mock2;
+ our $x;
+ {
+ main::callthrough(*main::x, 5);
+ Test::More::is($x, undef, 'localize qualified glob [ok - SUTM2]');
+ Test::More::is($main::x, 5, 'localize qualified glob [ok - main]');
+ }
+}
+
+{
+ package Scope::Upper::Test::Mock3;
+ our $x;
+ {
+ main::callthrough('$main::x', 6);
+ Test::More::is($x, undef, 'localize fully qualified name [ok - SUTM3]');
+ Test::More::is($main::x, 6, 'localize fully qualified name [ok - main]');
+ }
+}
+
+{
+ package Scope::Upper::Test::Mock4;
+ our $x;
+ {
+ main::callthrough('$x', 7);
+ Test::More::is($x, 7, 'localize unqualified name [ok - SUTM4]');
+ Test::More::is($main::x, undef, 'localize unqualified name [ok - main]');
+ }
+}
+
+$_ = 'foo';
+{
+ package Scope::Upper::Test::Mock5;
+ {
+ main::callthrough('$_', 'bar');
+ Test::More::ok(/bar/, 'localize $_ [ok]');
+ }
+}
+undef $_;
+
+# Arrays
+
+our @a;
+my $xa = [ 7 .. 9 ];
+
+{
+ local @a = (4 .. 6);
+ {
+ localize *a, $xa, 0;
+ is_deeply \@a, $xa, 'localize *a, [ ], 0 [ok]';
+ }
+ is_deeply \@a, [ 4 .. 6 ], 'localize *a, [ ], 0 [end]';
+}
+
+{
+ local @a = (4 .. 6);
+ {
+ local @a = (5 .. 7);
+ {
+ localize *a, $xa, 1;
+ is_deeply \@a, [ 5 .. 7 ], 'localize *a, [ ], 1 [not yet]';
+ }
+ is_deeply \@a, $xa, 'localize *a, [ ], 1 [ok]';
+ }
+ is_deeply \@a, [ 4 .. 6 ], 'localize *a, [ ], 1 [end]';
+}
+
+# Hashes
+
+our %h;
+my $xh = { a => 5, c => 7 };
+
+{
+ local %h = (a => 1, b => 2);
+ {
+ localize *h, $xh, 0;
+ is_deeply \%h, $xh, 'localize *h, { }, 0 [ok]';
+ }
+ is_deeply \%h, { a => 1, b => 2 }, 'localize *h, { }, 0 [end]';
+}
+
+{
+ local %h = (a => 1, b => 2);
+ {
+ local %h = (b => 3, c => 4);
+ {
+ localize *h, $xh, 1;
+ is_deeply \%h, { b => 3, c => 4 }, 'localize *h, { }, 1 [not yet]';
+ }
+ is_deeply \%h, $xh, 'localize *h, { }, 1 [ok]';
+ }
+ is_deeply \%h, { a => 1, b => 2 }, 'localize *h, { }, 1 [end]';
+}
+
+# Code
+
+{
+ local *foo = sub { 7 };
+ {
+ localize *foo, sub { 6 }, 1;
+ is foo(), 7, 'localize *foo, sub { 6 }, 1 [not yet]';
+ }
+ is foo(), 6, 'localize *foo, sub { 6 }, 1 [ok]';
+}
+
+{
+ local *foo = sub { 9 };
+ {
+ localize '&foo', sub { 8 }, 1;
+ is foo(), 9, 'localize "&foo", sub { 8 }, 1 [not yet]';
+ }
+ is foo(), 8, 'localize "&foo", sub { 8 }, 1 [ok]';
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use Scope::Upper qw/localize_elem/;
+
+use lib 't/lib';
+use Scope::Upper::TestGenerator;
+
+our ($x, $testcase);
+
+local $Scope::Upper::TestGenerator::call = sub {
+ my ($height, $level, $i) = @_;
+ return [ "localize_elem '\@main::a', 1 => 3 => $level;\n" ];
+};
+
+local $Scope::Upper::TestGenerator::test = sub {
+ my ($height, $level, $i) = @_;
+ my $j = ($i == $height - $level) ? '1, 3' : '1, 2';
+ return "is_deeply(\\\@main::a, [ $j ], 'a h=$height, l=$level, i=$i');\n";
+};
+
+our @a;
+
+for my $level (0 .. 4) {
+ for my $height ($level + 1 .. $level + 2) {
+ my $tests = Scope::Upper::TestGenerator::gen($height, $level);
+ for (@$tests) {
+ $testcase = $_;
+ $x = undef;
+ @a = (1, 2);
+ eval;
+ diag $@ if $@;
+ }
+ }
+}
+
+local $Scope::Upper::TestGenerator::call = sub {
+ my ($height, $level, $i) = @_;
+ return [ "localize_elem '%main::h', 'a' => 1 => $level;\n" ];
+};
+
+local $Scope::Upper::TestGenerator::test = sub {
+ my ($height, $level, $i) = @_;
+ my $j = ($i == $height - $level) ? 'a => 1' : '';
+ return "is_deeply(\\%main::h, { $j }, 'h h=$height, l=$level, i=$i');\n";
+};
+
+our %h;
+
+for my $level (0 .. 4) {
+ for my $height ($level + 1 .. $level + 2) {
+ my $tests = Scope::Upper::TestGenerator::gen($height, $level);
+ for (@$tests) {
+ $testcase = $_;
+ $x = undef;
+ %h = ();
+ eval;
+ diag $@ if $@;
+ }
+ }
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use Scope::Upper qw/localize_elem/;
+
+use lib 't/lib';
+use Scope::Upper::TestGenerator;
+
+local $Scope::Upper::TestGenerator::testlocal = sub { '' };
+
+local $Scope::Upper::TestGenerator::allblocks = 1;
+
+our $testcase;
+
+local $Scope::Upper::TestGenerator::call = sub {
+ my ($height, $level, $i) = @_;
+ return [ "localize_elem '\@a', 1 => 0 => $level;\n" ];
+};
+
+local $Scope::Upper::TestGenerator::test = sub {
+ my ($height, $level, $i, $x) = @_;
+ my $j = ($i == $height - $level) ? 0 : (defined $x ? $x : 11);
+ return "is(\$a[1], $j, 'x h=$height, l=$level, i=$i');\n";
+};
+
+local $Scope::Upper::TestGenerator::local = sub {
+ my $x = $_[3];
+ return "local \$a[1] = $x;\n";
+};
+
+our @a;
+
+for my $level (0 .. 1) {
+ my $height = $level + 1;
+ my $tests = Scope::Upper::TestGenerator::gen($height, $level);
+ for (@$tests) {
+ $testcase = $_;
+ @a = (10, 11);
+ eval;
+ diag $@ if $@;
+ }
+}
+
+local $Scope::Upper::TestGenerator::call = sub {
+ my ($height, $level, $i) = @_;
+ return [ "localize_elem '%h', 'a' => 0 => $level;\n" ];
+};
+
+local $Scope::Upper::TestGenerator::test = sub {
+ my ($height, $level, $i, $x) = @_;
+ my $j = ($i == $height - $level) ? 0 : (defined $x ? $x : 'undef');
+ return "is(\$h{a}, $j, 'x h=$height, l=$level, i=$i');\n";
+};
+
+local $Scope::Upper::TestGenerator::local = sub {
+ my $x = $_[3];
+ return "local \$h{a} = $x;\n";
+};
+
+our %h;
+
+for my $level (0 .. 1) {
+ my $height = $level + 1;
+ my $tests = Scope::Upper::TestGenerator::gen($height, $level);
+ for (@$tests) {
+ $testcase = $_;
+ %h = ();
+ eval;
+ diag $@ if $@;
+ }
+}
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Scope::Upper qw/localize_elem/;
+
+use Test::More tests => 6;
+
+our $x;
+
+{
+ local $x;
+ local $SIG{__WARN__} = sub { };
+ {
+ {
+ localize_elem '%SIG', '__WARN__' => sub { $x = join '', @_ }, 1;
+ is $x, undef, 'localize_elem $SIG{__WARN__} [not yet]';
+ }
+ warn "1\n";
+ is $x, "1\n", 'localize_elem $SIG{__WARN__} [ok]';
+ }
+ warn "2\n";
+ is $x, "1\n", 'localize_elem $SIG{__WARN__} [done]';
+}
+
+sub runperl {
+ my ($val, $in, $desc) = @_;
+ system { $^X } $^X, '-e', "exit(\$ENV{SCOPE_UPPER_TEST} == $val ? 0 : 1)";
+SKIP: {
+ skip "system() failed: $!" => 1 if $? == -1;
+ if ($in) {
+ is $?, 0, $desc;
+ } else {
+ isnt $?, 0, $desc;
+ }
+ }
+}
+
+eval "setpgrp 0, 0";
+
+my $time = time;
+{
+ local $ENV{SCOPE_UPPER_TEST};
+ {
+ {
+ localize_elem '%ENV', 'SCOPE_UPPER_TEST' => $time, 1;
+ runperl $time, 0, 'localize_elem $ENV{SCOPE_UPPER_TEST} [not yet]';
+ }
+ runperl $time, 1, 'localize_elem $ENV{SCOPE_UPPER_TEST} [ok]';
+ }
+ runperl $time, 0, 'localize_elem $ENV{SCOPE_UPPER_TEST} [done]';
+}
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+
+use Scope::Upper qw/localize_elem/;
+
+# Arrays
+
+our @a;
+
+{
+ local @a = (4 .. 6);
+ {
+ localize_elem '@main::a', 1, 8, 0;
+ is_deeply \@a, [ 4, 8, 6 ], 'localize_elem "@a", 1, 8, 0 [ok]';
+ }
+ is_deeply \@a, [ 4 .. 6 ], 'localize_elem "@a", 1, 8, 0 [end]';
+}
+
+{
+ local @a = (4 .. 6);
+ {
+ localize_elem '@main::a', 4, 8, 0;
+ is_deeply \@a, [ 4 .. 6, undef, 8 ], 'localize_elem "@a", 4, 8, 0 [ok]';
+ }
+ is_deeply \@a, [ 4 .. 6, undef, undef ], 'localize_elem "@a", 4, 8, 0 [end]';
+}
+
+{
+ local @a = (4 .. 6);
+ {
+ local @a = (5 .. 7);
+ {
+ localize_elem '@main::a', 1, 12, 1;
+ is_deeply \@a, [ 5 .. 7 ], 'localize_elem "@a", 1, 12, 1 [not yet]';
+ }
+ is_deeply \@a, [ 5, 12, 7 ], 'localize_elem "@a", 1, 12, 1 [ok]';
+ }
+ is_deeply \@a, [ 4 .. 6 ], 'localize_elem "@a", 1, 12, 1 [end]';
+}
+
+# Hashes
+
+our %h;
+
+{
+ local %h = (a => 1, b => 2);
+ {
+ localize_elem '%main::h', 'a', 3, 0;
+ is_deeply \%h, { a => 3, b => 2 }, 'localize_elem "%h", "a", 3, 0 [ok]';
+ }
+ is_deeply \%h, { a => 1, b => 2 }, 'localize_elem "%h", "a", 3, 0 [end]';
+}
+
+{
+ local %h = (a => 1, b => 2);
+ {
+ localize_elem '%main::h', 'c', 3, 0;
+ is_deeply \%h, { a => 1, b => 2, c => 3 }, 'localize_elem "%h", "c", 3, 0 [ok]';
+ }
+ is_deeply \%h, { a => 1, b => 2 }, 'localize_elem "%h", "c", 3, 0 [end]';
+}
+
+{
+ local %h = (a => 1, b => 2);
+ {
+ local %h = (a => 3, c => 4);
+ {
+ localize_elem '%main::h', 'a', 5, 1;
+ is_deeply \%h, { a => 3, c => 4 }, 'localize_elem "%h", "a", 5, 1 [not yet]';
+ }
+ is_deeply \%h, { a => 5, c => 4 }, 'localize_elem "%h", "a", 5, 1 [ok]';
+ }
+ is_deeply \%h, { a => 1, b => 2 }, 'localize_elem "%h", "a", 5, 1 [end]';
+}
+
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+sub not_in_file_ok {
+ my ($filename, %regex) = @_;
+ open( my $fh, '<', $filename )
+ or die "couldn't open $filename for reading: $!";
+
+ my %violated;
+
+ while (my $line = <$fh>) {
+ while (my ($desc, $regex) = each %regex) {
+ if ($line =~ $regex) {
+ push @{$violated{$desc}||=[]}, $.;
+ }
+ }
+ }
+
+ if (%violated) {
+ fail("$filename contains boilerplate text");
+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
+ } else {
+ pass("$filename contains no boilerplate text");
+ }
+}
+
+sub module_boilerplate_ok {
+ my ($module) = @_;
+ not_in_file_ok($module =>
+ 'the great new $MODULENAME' => qr/ - The great new /,
+ 'boilerplate description' => qr/Quick summary of what the module/,
+ 'stub function definition' => qr/function[12]/,
+ );
+}
+
+not_in_file_ok(README =>
+ "The README is used..." => qr/The README is used/,
+ "'version information here'" => qr/to provide version information/,
+);
+
+not_in_file_ok(Changes =>
+ "placeholder date/time" => qr(Date/time)
+);
+
+module_boilerplate_ok('lib/Scope/Upper.pm');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+# Ensure a recent version of Test::Pod::Coverage
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@;
+
+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
+# but older versions don't recognize some common documentation styles
+my $min_pc = 0.18;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@;
+
+all_pod_coverage_ok();
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Portability::Files";
+plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@;
+run_tests();
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval { require Test::Kwalitee; Test::Kwalitee->import() };
+plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
--- /dev/null
+package Scope::Upper::TestGenerator;
+
+use strict;
+use warnings;
+
+our ($call, $test, $local, $testlocal, $allblocks);
+
+$local = sub {
+ my $x = $_[3];
+ return "local \$x = $x;\n";
+};
+
+$testlocal = sub {
+ my ($height, $level, $i, $x) = @_;
+ my $j = defined $x ? $x : 'undef';
+ return "is(\$x, $j, 'x h=$height, l=$level, i=$i');\n";
+};
+
+my @blocks = (
+ [ '{', '}' ],
+ [ 'sub {', '}->();' ],
+ [ 'do {', '};' ],
+ [ 'eval {', '};' ],
+ [ 'for (1) {', '}' ],
+ [ 'eval q[', '];' ],
+);
+
+@blocks = map [ map "$_\n", @$_ ], @blocks;
+
+sub _block {
+ my ($height, $level, $i) = @_;
+ my $j = $height - $i;
+ $j = 0 if $j > $#blocks or $j < 0;
+ return [ map "$_\n", @{$blocks[$j]} ];
+}
+
+sub gen {
+ my ($height, $level, $i, $x) = @_;
+ push @_, $i = 0 if @_ == 2;
+ return $call->(@_) if $height < $i;
+ my @res;
+ my @blks = $allblocks ? @blocks : _block(@_);
+ my $up = gen($height, $level, $i + 1, $x);
+ for my $base (@$up) {
+ for my $blk (@blks) {
+ push @res, $blk->[0] . $base . $test->(@_) . $testlocal->(@_) . $blk->[1];
+ }
+ }
+ $_[3] = $i + 1;
+ $up = gen($height, $level, $i + 1, $i + 1);
+ for my $base (@$up) {
+ for my $blk (@blks) {
+ push @res, $blk->[0] .
+ $local->(@_) . $base . $test->(@_) . $testlocal->(@_)
+ . $blk->[1];
+ }
+ }
+ return \@res;
+}
+
+1;
projects / perl / modules / Scope-Upper.git / commitdiff