From: Vincent Pit Date: Fri, 16 Jan 2009 22:33:35 +0000 (+0100) Subject: Introduce SCOPE() X-Git-Tag: v0.06~3 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=b74d16df98351c4bacb0a1a9d029ce7d7924591f;p=perl%2Fmodules%2FScope-Upper.git Introduce SCOPE() --- diff --git a/Upper.xs b/Upper.xs index b6e473d..cd093de 100644 --- a/Upper.xs +++ b/Upper.xs @@ -654,6 +654,18 @@ STATIC void su_unwind(pTHX_ void *ud_) { } \ } STMT_END +#define SU_GET_LEVEL(A, B) \ + STMT_START { \ + if (items > 0) { \ + SV *lsv = ST(B); \ + if (SvOK(lsv)) \ + level = SvIV(lsv); \ + if (level < 0) \ + level = 0; \ + } else \ + level = 0; \ + } STMT_END + XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */ XS(XS_Scope__Upper_unwind) { @@ -786,18 +798,36 @@ PPCODE: XSRETURN_UNDEF; void -CALLER(...) +SCOPE(...) PROTOTYPE: ;$ PREINIT: - I32 cxix, caller = 0; + I32 cxix, level; PPCODE: - if (items) { - SV *csv = ST(0); - if (SvOK(csv)) - caller = SvIV(csv); - if (caller < 0) - caller = 0; + SU_GET_LEVEL(0, 0); + cxix = cxstack_ix; + if (PL_DBsub) { + SU_SKIP_DB(cxix); + while (cxix > 0) { + if (--level < 0) + break; + --cxix; + SU_SKIP_DB(cxix); + } + } else { + cxix -= level; + if (cxix < 0) + cxix = 0; } + ST(0) = sv_2mortal(newSViv(cxix)); + XSRETURN(1); + +void +CALLER(...) +PROTOTYPE: ;$ +PREINIT: + I32 cxix, level; +PPCODE: + SU_GET_LEVEL(0, 0); for (cxix = cxstack_ix; cxix > 0; --cxix) { PERL_CONTEXT *cx = cxstack + cxix; switch (CxTYPE(cx)) { @@ -806,8 +836,7 @@ PPCODE: continue; case CXt_EVAL: case CXt_FORMAT: - --caller; - if (caller < 0) + if (--level < 0) goto done; break; } diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm index ffd3c75..45bdbe2 100644 --- a/lib/Scope/Upper.pm +++ b/lib/Scope/Upper.pm @@ -108,6 +108,10 @@ 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. +=head2 C + +The C<$stack>-th upper frame. + =head2 C The level of the C<$stack>-th upper subroutine/eval/format context. @@ -220,7 +224,7 @@ will righteously set C<$num> to C<26>. The functions L, L, 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'>. +Same goes for the words L, L, L, L, L, L and L that are only exported on request, individually or by the tags C<':words'> and C<':all'>. =cut @@ -229,7 +233,7 @@ use base qw/Exporter/; our @EXPORT = (); our %EXPORT_TAGS = ( funcs => [ qw/reap localize localize_elem localize_delete unwind want_at/ ], - words => [ qw/TOP HERE UP SUB EVAL CALLER/ ], + words => [ qw/TOP HERE UP SUB EVAL SCOPE CALLER/ ], ); 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 fe4f1c5..a0134bb 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -3,11 +3,11 @@ use strict; use warnings; -use Test::More tests => 12; +use Test::More tests => 13; require Scope::Upper; -for (qw/reap localize localize_elem localize_delete unwind want_at TOP HERE UP SUB EVAL CALLER/) { +for (qw/reap localize localize_elem localize_delete unwind want_at TOP HERE UP SUB EVAL SCOPE CALLER/) { eval { Scope::Upper->import($_) }; is($@, '', 'import ' . $_); } diff --git a/t/05-words.t b/t/05-words.t index b1d1467..2405d6b 100644 --- a/t/05-words.t +++ b/t/05-words.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 42; +use Test::More tests => 29 + 13 * 2; use Scope::Upper qw/:words/; @@ -72,22 +72,35 @@ do { } while (0); { - is CALLER, 0, '{ } : caller'; - is CALLER(0), 0, '{ } : caller 0'; - is CALLER(1), 0, '{ } : caller 1'; + is SCOPE, 1, 'block : scope'; + is SCOPE(0), 1, 'block : scope 0'; + is SCOPE(1), 0, 'block : scope 1'; + is CALLER, 0, 'block: caller'; + is CALLER(0), 0, 'block : caller 0'; + is CALLER(1), 0, 'block : caller 1'; sub { - is CALLER, 2, '{ sub { } } : caller'; - is CALLER(0), 2, '{ sub { } } : caller 0'; - is CALLER(1), 0, '{ sub { } } : caller 1'; + is SCOPE, 2, 'block sub : scope'; + is SCOPE(0), 2, 'block sub : scope 0'; + is SCOPE(1), 1, 'block sub : scope 1'; + is CALLER, 2, 'block sub : caller'; + is CALLER(0), 2, 'block sub : caller 0'; + is CALLER(1), 0, 'block sub : caller 1'; for (1) { - is CALLER, 2, '{ sub { for { } } } : caller'; - is CALLER(0), 2, '{ sub { for { } } } : caller 0'; - is CALLER(1), 0, '{ sub { for { } } } : caller 1'; + is SCOPE, 3, 'block sub for : scope'; + is SCOPE(0), 3, 'block sub for : scope 0'; + is SCOPE(1), 2, 'block sub for : scope 1'; + is CALLER, 2, 'block sub for : caller'; + is CALLER(0), 2, 'block sub for : caller 0'; + is CALLER(1), 0, 'block sub for : caller 1'; eval { - is CALLER, 4, '{ sub { for { eval { } } } } : caller'; - is CALLER(0), 4, '{ sub { for { eval { } } } } : caller 0'; - is CALLER(1), 2, '{ sub { for { eval { } } } } : caller 1'; - is CALLER(2), 0, '{ sub { for { eval { } } } } : caller 2'; + is SCOPE, 4, 'block sub for eval : scope'; + is SCOPE(0), 4, 'block sub for eval : scope 0'; + is SCOPE(1), 3, 'block sub for eval : scope 1'; + is SCOPE(2), 2, 'block sub for eval : scope 2'; + is CALLER, 4, 'block sub for eval : caller'; + is CALLER(0), 4, 'block sub for eval : caller 0'; + is CALLER(1), 2, 'block sub for eval : caller 1'; + is CALLER(2), 0, 'block sub for eval : caller 2'; } } }->(); diff --git a/t/55-unwind-multi.t b/t/55-unwind-multi.t index aa37026..dd8c727 100644 --- a/t/55-unwind-multi.t +++ b/t/55-unwind-multi.t @@ -5,7 +5,7 @@ use warnings; use Test::More tests => 13; -use Scope::Upper qw/unwind/; +use Scope::Upper qw/unwind SCOPE/; my ($l1, $l2); @@ -17,10 +17,10 @@ sub c { unwind("eval", eval { do { for (3, 4, 5) { - 1, unwind('from', 'the', 'sub', 'c' => $l1); + 1, unwind('from', 'the', 'sub', 'c' => SCOPE $l1); } } - } => $l2); + } => SCOPE $l2); }->(2, 3, 4); return 'in c' }