From: Vincent Pit Date: Fri, 26 Dec 2008 16:10:59 +0000 (+0100) Subject: Importing Scope-Upper-0.01 X-Git-Tag: v0.01^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=bac4fc46c2d48ce5db75de6c88e0983aeeedf865 Importing Scope-Upper-0.01 --- bac4fc46c2d48ce5db75de6c88e0983aeeedf865 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..1764688 --- /dev/null +++ b/.gitignore @@ -0,0 +1,25 @@ +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 diff --git a/Changes b/Changes new file mode 100644 index 0000000..7cb3a02 --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for Scope-Upper + +0.01 2008-12-26 16:05 UTC + First version, released on an unsuspecting world. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..55e9840 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,30 @@ +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) diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..c56dad6 --- /dev/null +++ b/META.yml @@ -0,0 +1,23 @@ +--- #YAML:1.0 +name: Scope-Upper +version: 0.01 +abstract: Act on upper scopes. +author: + - Vincent Pit +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 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..20649ec --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,36 @@ +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 ', + 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' }, +); diff --git a/README b/README new file mode 100644 index 0000000..52a7611 --- /dev/null +++ b/README @@ -0,0 +1,123 @@ +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, "", . + + 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 + . 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. + diff --git a/Upper.xs b/Upper.xs new file mode 100644 index 0000000..09bfe6c --- /dev/null +++ b/Upper.xs @@ -0,0 +1,463 @@ +/* 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; + diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm new file mode 100644 index 0000000..0835364 --- /dev/null +++ b/lib/Scope/Upper.pm @@ -0,0 +1,168 @@ +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 + +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 + +A C 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 follows then the same syntax as C. +For example, if C<$value> is a scalar reference, then the C slot of the glob will be set to C<$$value> - just like C 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 is called. +This means that + + sub tag { localize '$x', $_[0] => 1; } + +will localize in the caller's namespace. + +=back + +=head2 C + +Similar to L 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 + +Returns the level that currently represents the highest scope. + +=head1 EXPORT + +The functions L, L, L and L 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 (standard since perl 5.006). + +=head1 SEE ALSO + +L, L, L, L. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +You can contact me by mail or on C (vincent). + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at L. 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 diff --git a/samples/tag.pl b/samples/tag.pl new file mode 100644 index 0000000..9020121 --- /dev/null +++ b/samples/tag.pl @@ -0,0 +1,42 @@ +#!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 diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..fc7c629 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,12 @@ +#!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" ); diff --git a/t/01-import.t b/t/01-import.t new file mode 100644 index 0000000..9b3eb0b --- /dev/null +++ b/t/01-import.t @@ -0,0 +1,13 @@ +#!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 ' . $_); +} diff --git a/t/05-TOPLEVEL.t b/t/05-TOPLEVEL.t new file mode 100644 index 0000000..37502e0 --- /dev/null +++ b/t/05-TOPLEVEL.t @@ -0,0 +1,52 @@ +#!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); diff --git a/t/10-reap.t b/t/10-reap.t new file mode 100644 index 0000000..11919dd --- /dev/null +++ b/t/10-reap.t @@ -0,0 +1,233 @@ +#!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'); diff --git a/t/11-reap-level.t b/t/11-reap-level.t new file mode 100644 index 0000000..ccee71b --- /dev/null +++ b/t/11-reap-level.t @@ -0,0 +1,55 @@ +#!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 < $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 < 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]'; +} diff --git a/t/20-localize.t b/t/20-localize.t new file mode 100644 index 0000000..35a22c6 --- /dev/null +++ b/t/20-localize.t @@ -0,0 +1,107 @@ +#!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'); + diff --git a/t/21-localize-level.t b/t/21-localize-level.t new file mode 100644 index 0000000..d9cdf97 --- /dev/null +++ b/t/21-localize-level.t @@ -0,0 +1,53 @@ +#!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 < 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 < 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]'; +} diff --git a/t/29-localize-target.t b/t/29-localize-target.t new file mode 100644 index 0000000..5b14904 --- /dev/null +++ b/t/29-localize-target.t @@ -0,0 +1,245 @@ +#!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]'; +} diff --git a/t/31-localize_elem-level.t b/t/31-localize_elem-level.t new file mode 100644 index 0000000..6f73cc4 --- /dev/null +++ b/t/31-localize_elem-level.t @@ -0,0 +1,65 @@ +#!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 $@; + } + } +} diff --git a/t/32-localize_elem-block.t b/t/32-localize_elem-block.t new file mode 100644 index 0000000..36014bd --- /dev/null +++ b/t/32-localize_elem-block.t @@ -0,0 +1,75 @@ +#!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 $@; + } +} diff --git a/t/38-localize_elem-magic.t b/t/38-localize_elem-magic.t new file mode 100644 index 0000000..2db3e2f --- /dev/null +++ b/t/38-localize_elem-magic.t @@ -0,0 +1,53 @@ +#!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]'; +} diff --git a/t/39-localize_elem-target.t b/t/39-localize_elem-target.t new file mode 100644 index 0000000..6a83407 --- /dev/null +++ b/t/39-localize_elem-target.t @@ -0,0 +1,79 @@ +#!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]'; +} + diff --git a/t/90-boilerplate.t b/t/90-boilerplate.t new file mode 100644 index 0000000..ef6f8bc --- /dev/null +++ b/t/90-boilerplate.t @@ -0,0 +1,49 @@ +#!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'); diff --git a/t/91-pod.t b/t/91-pod.t new file mode 100644 index 0000000..62d2d7f --- /dev/null +++ b/t/91-pod.t @@ -0,0 +1,13 @@ +#!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(); diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t new file mode 100644 index 0000000..3037c13 --- /dev/null +++ b/t/92-pod-coverage.t @@ -0,0 +1,19 @@ +#!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(); diff --git a/t/95-portability-files.t b/t/95-portability-files.t new file mode 100644 index 0000000..ab541f3 --- /dev/null +++ b/t/95-portability-files.t @@ -0,0 +1,10 @@ +#!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(); diff --git a/t/99-kwalitee.t b/t/99-kwalitee.t new file mode 100644 index 0000000..7775e60 --- /dev/null +++ b/t/99-kwalitee.t @@ -0,0 +1,9 @@ +#!perl + +use strict; +use warnings; + +use Test::More; + +eval { require Test::Kwalitee; Test::Kwalitee->import() }; +plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@; diff --git a/t/lib/Scope/Upper/TestGenerator.pm b/t/lib/Scope/Upper/TestGenerator.pm new file mode 100644 index 0000000..af26787 --- /dev/null +++ b/t/lib/Scope/Upper/TestGenerator.pm @@ -0,0 +1,61 @@ +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;