From: Vincent Pit Date: Sun, 11 Jan 2009 16:46:02 +0000 (+0100) Subject: Introduce CALLER() X-Git-Tag: v0.04~6 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=6dcecbd373fc489246bf75ad4472312d92216551;p=perl%2Fmodules%2FScope-Upper.git Introduce CALLER() --- diff --git a/Upper.xs b/Upper.xs index 60e8a0c..f55b18c 100644 --- a/Upper.xs +++ b/Upper.xs @@ -700,6 +700,35 @@ PROTOTYPE: ;$ PPCODE: SU_DOPOPTOCX(CXt_EVAL); +void +CALLER(...) +PROTOTYPE: ;$ +PREINIT: + I32 cxix = cxstack_ix, caller = 0, level = 0; +PPCODE: + if (items) { + SV *csv = ST(0); + if (SvOK(csv)) + caller = SvIV(csv); + } + cxix = cxstack_ix; + while (cxix > 0) { + PERL_CONTEXT *cx = cxstack + cxix--; + switch (CxTYPE(cx)) { + case CXt_SUB: + case CXt_EVAL: + case CXt_FORMAT: + --caller; + if (caller < 0) + goto done; + break; + } + ++level; + } +done: + ST(0) = sv_2mortal(newSViv(level)); + XSRETURN(1); + void reap(SV *hook, ...) PROTOTYPE: &;$ diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm index 259ee7f..710f86c 100644 --- a/lib/Scope/Upper.pm +++ b/lib/Scope/Upper.pm @@ -169,11 +169,15 @@ 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 level corresponding to the stack referenced by C. + =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'>. -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 @@ -182,7 +186,7 @@ use base qw/Exporter/; our @EXPORT = (); our %EXPORT_TAGS = ( funcs => [ qw/reap localize localize_elem localize_delete unwind/ ], - words => [ qw/TOP HERE UP DOWN SUB EVAL/ ], + words => [ qw/TOP HERE UP DOWN SUB EVAL 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 06c02b3..35d8212 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -3,11 +3,11 @@ use strict; use warnings; -use Test::More tests => 11; +use Test::More tests => 12; require Scope::Upper; -for (qw/reap localize localize_elem localize_delete unwind TOP HERE UP DOWN SUB EVAL/) { +for (qw/reap localize localize_elem localize_delete unwind TOP HERE UP DOWN SUB EVAL CALLER/) { eval { Scope::Upper->import($_) }; is($@, '', 'import ' . $_); } diff --git a/t/05-words.t b/t/05-words.t index 751b464..a52a362 100644 --- a/t/05-words.t +++ b/t/05-words.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 33; +use Test::More tests => 46; use Scope::Upper qw/:words/; @@ -74,3 +74,25 @@ do { } }; } while (0); + +{ + is CALLER, 1, '{ } : caller'; + is CALLER(0), 1, '{ } : caller 0'; + is CALLER(1), 1, '{ } : caller 1'; + sub { + is CALLER, 0, '{ sub { } } : caller'; + is CALLER(0), 0, '{ sub { } } : caller 0'; + is CALLER(1), 2, '{ sub { } } : caller 1'; + for (1) { + is CALLER, 1, '{ sub { for { } } } : caller'; + is CALLER(0), 1, '{ sub { for { } } } : caller 0'; + is CALLER(1), 3, '{ sub { for { } } } : caller 1'; + eval { + is CALLER, 0, '{ sub { for { eval { } } } } : caller'; + is CALLER(0), 0, '{ sub { for { eval { } } } } : caller 0'; + is CALLER(1), 2, '{ sub { for { eval { } } } } : caller 1'; + is CALLER(2), 4, '{ sub { for { eval { } } } } : caller 2'; + } + } + }->(); +}