Add more level words. Rename TOPLEVEL to TOP

diff --git a/MANIFEST b/MANIFEST
index 5452cf7a36586e1b035dae467d6dd5b97055e454..a4f11d78d93a5f46eff946e5f186488283362b42 100644 (file)
--- 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 0235cbee67610a06e354d7cd40611d0e6a0f8d4e..4e2f45f229452b65447d2af2bbfe0ec92c6f92f3 100644 (file)
--- 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 345176add9a801ae293ccefe2a182672cf3ca9b2..3c641ac5c813f45a2d22530ec5db19dc828ed8f2 100644 (file)
--- a/lib/Scope/Upper.pm
+++ b/lib/Scope/Upper.pm
@@ -136,13 +136,39 @@ C<$key> is ignored.
 
 =back
 
-=head2 C<TOPLEVEL>
+=head1 WORDS
+
+=head2 C<TOP>
 
 Returns the level that currently represents the highest scope.
 
+=head2 C<CURRENT>
+
+The current level - i.e. C<0>.
+
+=head2 C<UP $from>
+
+The level of the scope just above C<$from>.
+
+=head2 C<DOWN $from>
+
+The level of the scope just below C<$from>.
+
+=head2 C<SUB $from>
+
+The level of the closest subroutine context above C<$from>.
+
+=head2 C<EVAL $from>
+
+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</reap>, L</localize>, L</localize_elem>, L</localize_delete> and L</TOPLEVEL> are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>.
+The functions L</reap>, L</localize>, L</localize_elem> and L</localize_delete> are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>.
+
+Same goes for the words L</TOP>, L</CURRENT>, L</UP>, L</DOWN>, L</SUB> and L</EVAL> 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 9b3eb0b1a4138ac8642f6557a8aefe76fe41a99b..ef8937c62b698542e158ec150d7aeb23dd039068 100644 (file)
--- 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 (file)
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 (file)
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);