From: Vincent Pit Date: Mon, 5 Jan 2009 10:24:05 +0000 (+0100) Subject: Add more level words. Rename TOPLEVEL to TOP X-Git-Tag: v0.04~24 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=02798a015a7fae0ff3d924b3270def3996e4210b;p=perl%2Fmodules%2FScope-Upper.git Add more level words. Rename TOPLEVEL to TOP --- diff --git a/MANIFEST b/MANIFEST index 5452cf7..a4f11d7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -7,7 +7,7 @@ lib/Scope/Upper.pm samples/tag.pl t/00-load.t t/01-import.t -t/05-TOPLEVEL.t +t/05-words.t t/10-reap.t t/11-reap-level.t t/12-reap-block.t diff --git a/Upper.xs b/Upper.xs index 0235cbe..4e2f45f 100644 --- a/Upper.xs +++ b/Upper.xs @@ -6,6 +6,8 @@ #include "perl.h" #include "XSUB.h" +#define __PACKAGE__ "Scope::Upper" + #ifndef SU_DEBUG # define SU_DEBUG 0 #endif @@ -520,20 +522,81 @@ done: if (level > cxstack_ix) \ level = cxstack_ix; +#define SU_DOPOPTOCX(t) \ + STMT_START { \ + I32 i, cxix = cxstack_ix, from = 0; \ + if (items) \ + from = SvIV(ST(0)); \ + for (i = cxix - from; i >= 0; --i) { \ + if (CxTYPE(&cxstack[i]) == t) { \ + ST(0) = sv_2mortal(newSViv(cxix - i)); \ + XSRETURN(1); \ + } \ + } \ + XSRETURN_UNDEF; \ + } STMT_END + /* --- XS ------------------------------------------------------------------ */ MODULE = Scope::Upper PACKAGE = Scope::Upper PROTOTYPES: ENABLE +BOOT: +{ + HV *stash = gv_stashpv(__PACKAGE__, 1); + newCONSTSUB(stash, "CURRENT", newSViv(0)); +} + SV * -TOPLEVEL() +TOP() PROTOTYPE: CODE: RETVAL = newSViv(cxstack_ix); OUTPUT: RETVAL +SV * +UP(...) +PROTOTYPE: ;$ +PREINIT: + I32 i = 0; + I32 cxix = cxstack_ix; +CODE: + if (items) + i = SvIV(ST(0)); + if (++i > cxix) + i = cxix; + RETVAL = newSViv(i); +OUTPUT: + RETVAL + +SV * +DOWN(...) +PROTOTYPE: ;$ +PREINIT: + I32 i = 0; +CODE: + if (items) + i = SvIV(ST(0)); + if (--i < 0) + i = 0; + RETVAL = newSViv(i); +OUTPUT: + RETVAL + +void +SUB(...) +PROTOTYPE: ;$ +PPCODE: + SU_DOPOPTOCX(CXt_SUB); + +void +EVAL(...) +PROTOTYPE: ;$ +PPCODE: + SU_DOPOPTOCX(CXt_EVAL); + void reap(SV *hook, ...) PROTOTYPE: &;$ diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm index 345176a..3c641ac 100644 --- a/lib/Scope/Upper.pm +++ b/lib/Scope/Upper.pm @@ -136,13 +136,39 @@ C<$key> is ignored. =back -=head2 C +=head1 WORDS + +=head2 C Returns the level that currently represents the highest scope. +=head2 C + +The current level - i.e. C<0>. + +=head2 C + +The level of the scope just above C<$from>. + +=head2 C + +The level of the scope just below C<$from>. + +=head2 C + +The level of the closest subroutine context above C<$from>. + +=head2 C + +The level of the closest eval context above C<$from>. + +If C<$from> is omitted in any of those functions, the current level is used as the reference level. + =head1 EXPORT -The functions L, L, L, L and L are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>. +The functions L, L, L and L are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>. + +Same goes for the words L, L, L, L, L and L that are only exported on request, individually or by the tags C<':words'> and C<':all'>. =cut @@ -150,7 +176,8 @@ use base qw/Exporter/; our @EXPORT = (); our %EXPORT_TAGS = ( - funcs => [ qw/reap localize localize_elem localize_delete TOPLEVEL/ ], + funcs => [ qw/reap localize localize_elem localize_delete/ ], + words => [ qw/TOP CURRENT UP DOWN SUB EVAL/ ], ); our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS; $EXPORT_TAGS{'all'} = [ @EXPORT_OK ]; diff --git a/t/01-import.t b/t/01-import.t index 9b3eb0b..ef8937c 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -3,11 +3,11 @@ use strict; use warnings; -use Test::More tests => 4; +use Test::More tests => 9; require Scope::Upper; -for (qw/reap localize localize_elem TOPLEVEL/) { +for (qw/reap localize localize_elem TOP CURRENT UP DOWN SUB EVAL/) { eval { Scope::Upper->import($_) }; is($@, '', 'import ' . $_); } diff --git a/t/05-TOPLEVEL.t b/t/05-TOPLEVEL.t deleted file mode 100644 index 37502e0..0000000 --- a/t/05-TOPLEVEL.t +++ /dev/null @@ -1,52 +0,0 @@ -#!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/05-words.t b/t/05-words.t new file mode 100644 index 0000000..2376d35 --- /dev/null +++ b/t/05-words.t @@ -0,0 +1,76 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 33; + +use Scope::Upper qw/:words/; + +is CURRENT, 0, 'main : current'; +is TOP, 0, 'main : top'; +is UP, 0, 'main : up'; +is DOWN, 0, 'main : down'; +is SUB, undef, 'main : sub'; +is EVAL, undef, 'main : eval'; + +{ + is CURRENT, 0, '{ 1 } : current'; + is TOP, 1, '{ 1 } : top'; + is UP, 1, '{ 1 } : up'; + is DOWN, 0, '{ 1 } : down'; + is DOWN(UP), 0, '{ 1 } : up then down'; + is UP(DOWN), 1, '{ 1 } : down then up'; +} + +do { + is TOP, 1, 'do { 1 } : top'; + is SUB, undef, 'do { 1 } : sub'; + is EVAL, undef, 'do { 1 } : eval'; +}; + +eval { + is TOP, 1, 'eval { 1 } : top'; + is SUB, undef, 'eval { 1 } : sub'; + is EVAL, 0, 'eval { 1 } : eval'; +}; + +eval q[ + is TOP, 1, 'eval "1" : top'; + is SUB, undef, 'eval "1" : sub'; + is EVAL, 0, 'eval "1" : eval'; +]; + +do { + is TOP, 1, 'do { 1 } while (0) : top'; +} while (0); + +sub { + is TOP, 1, 'sub { 1 } : top'; + is SUB, 0, 'sub { 1 } : sub'; + is EVAL, undef, 'sub { 1 } : eval'; +}->(); + +for (1) { + is TOP, 1, 'for () { 1 } : top'; +} + +do { + eval { + do { + sub { + eval q[ + { + is CURRENT, 0, 'mixed : current'; + is TOP, 6, 'mixed : top'; + is SUB, 2, 'mixed : first sub'; + is SUB(SUB), 2, 'mixed : still first sub'; + is EVAL, 1, 'mixed : first eval'; + is EVAL(EVAL), 1, 'mixed : still first eval'; + is EVAL(UP(EVAL)), 4, 'mixed : second eval'; + } + ]; + }->(); + } + }; +} while (0);