Introduce CALLER()

diff --git a/Upper.xs b/Upper.xs
index 60e8a0c80ecab6b44391c8d60bfe0703a7b58964..f55b18cd04f8580ce68e7fa201b7c876dccf9404 100644 (file)
--- 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 259ee7f839890adbb59f4c8184e2bd2b000470f4..710f86cc8d3d963f3f5c26ba1f7505e4fda75b23 100644 (file)
--- 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<CALLER $stack>
+
+The level corresponding to the stack referenced by C<caller $stack>.
+
 =head1 EXPORT
 
 The functions L</reap>, L</localize>, L</localize_elem>, L</localize_delete> and L</unwind> 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</DOWN>, L</SUB> and L</EVAL> 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</DOWN>, L</SUB>, L</EVAL> and L</CALLER> 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 06c02b3f42006ed68be186593bd797a7d55061d4..35d82124dfbdf6f698f124bef001d0c90c62569e 100644 (file)
--- 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 751b464b0a12ca7e0d37fdd78dff1ad3bdd1c6a5..a52a362adcd15d38b5af9941e2c60ecede089220 100644 (file)
--- 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';
+   }
+  }
+ }->();
+}