Introduce SCOPE()

diff --git a/Upper.xs b/Upper.xs
index b6e473da5a1cca7be75748f690441bee6e2ce1ce..cd093dea83fdb52c8771d94f461f5da65598ff53 100644 (file)
--- 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 ffd3c751298a97e8edc654d83c96223641e19e0e..45bdbe2a1c494aa10a72fe875bebdd259490e079 100644 (file)
--- 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<SCOPE $stack>
+
+The C<$stack>-th upper frame.
+
 =head2 C<CALLER $stack>
 
 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</reap>, L</localize>, L</localize_elem>, L</localize_delete>,  L</unwind> and L</want_at> are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>.
 
-Same goes for the words L</TOP>, L</HERE>, L</UP>, L</SUB>, L</EVAL> and L</CALLER> that are only exported on request, individually or by the tags C<':words'> and C<':all'>.
+Same goes for the words L</TOP>, L</HERE>, L</UP>, L</SUB>, L</EVAL>, L</SCOPE> and L</CALLER> 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 fe4f1c59dfbab801ac18ab43d88af66ae2d956d8..a0134bb818be80889db78a6c9fb5c8932daadbaf 100644 (file)
--- 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 b1d1467161c5db82c906353a8a45bd11e01c69da..2405d6ba47d54b1fc2ee6e5540bd1a2f47b2b95f 100644 (file)
--- 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 aa37026a69568463dfa937504720c441333d9da3..dd8c727393197fd3873028128951e5f4e9644d41 100644 (file)
--- 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'
 }