Introduce want_at()

diff --git a/MANIFEST b/MANIFEST
index d0a11d47fa3ec9e91aa1574395bed28f7d1cbd84..4041009db802af78fc15c01a955dc035c3918878 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -8,6 +8,7 @@ samples/tag.pl
 t/00-load.t
 t/01-import.t
 t/05-words.t
+t/06-want_at.t
 t/11-reap-level.t
 t/12-reap-block.t
 t/13-reap-ctl.t

diff --git a/Upper.xs b/Upper.xs
index f55b18cd04f8580ce68e7fa201b7c876dccf9404..6a0b35e77bfb733c038838f378c8001b7e7c88eb 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -729,6 +729,40 @@ done:
  ST(0) = sv_2mortal(newSViv(level));
  XSRETURN(1);
 
+void
+want_at(...)
+PROTOTYPE: ;$
+PREINIT:
+ I32 cxix = cxstack_ix, level = 0;
+PPCODE:
+ if (items) {
+  SV *lsv = ST(0);
+  if (SvOK(lsv))
+   level = SvIV(lsv);
+  if (level < 0)
+   level = 0;
+  else if (level > cxix)
+   level = cxix;
+ }
+ cxix -= level;
+ while (cxix > 0) {
+  PERL_CONTEXT *cx = cxstack + cxix--;
+  switch (CxTYPE(cx)) {
+   case CXt_SUB:
+   case CXt_EVAL:
+   case CXt_FORMAT: {
+    I32 gimme = cx->blk_gimme;
+    switch (gimme) {
+     case G_VOID:   XSRETURN_UNDEF; break;
+     case G_SCALAR: XSRETURN_NO;    break;
+     case G_ARRAY:  XSRETURN_YES;   break;
+    }
+    break;
+   }
+  }
+ }
+ XSRETURN_UNDEF;
+
 void
 reap(SV *hook, ...)
 PROTOTYPE: &;$

diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm
index 710f86cc8d3d963f3f5c26ba1f7505e4fda75b23..a315552a6479e83c0121400c3a826e7eece1ebb9 100644 (file)
--- a/lib/Scope/Upper.pm
+++ b/lib/Scope/Upper.pm
@@ -141,6 +141,10 @@ C<$key> is ignored.
 Returns C<@values> I<from> the context indicated by C<$level>, i.e. from the subroutine, eval or format just above C<$level>.
 The upper level isn't coerced onto C<@values>, which is hence always evaluated in list context.
 
+=head2 C<want_at $level>
+
+Like C<wantarray>, but for the subroutine/eval/format context just above C<$level>.
+
 =head1 WORDS
 
 =head2 C<TOP>
@@ -175,7 +179,7 @@ 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'>.
+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</DOWN>, L</SUB>, L</EVAL> and L</CALLER> that are only exported on request, individually or by the tags C<':words'> and C<':all'>.
 
@@ -185,7 +189,7 @@ use base qw/Exporter/;
 
 our @EXPORT      = ();
 our %EXPORT_TAGS = (
- funcs => [ qw/reap localize localize_elem localize_delete unwind/ ],
+ funcs => [ qw/reap localize localize_elem localize_delete unwind want_at/ ],
  words => [ qw/TOP HERE UP DOWN SUB EVAL CALLER/ ],
 );
 our @EXPORT_OK   = map { @$_ } values %EXPORT_TAGS;

diff --git a/t/01-import.t b/t/01-import.t
index 35d82124dfbdf6f698f124bef001d0c90c62569e..76452a0f5692afac73ea25396743e04356c233f2 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 TOP HERE UP DOWN SUB EVAL CALLER/) {
+for (qw/reap localize localize_elem localize_delete unwind want_at TOP HERE UP DOWN SUB EVAL CALLER/) {
  eval { Scope::Upper->import($_) };
  is($@, '', 'import ' . $_);
 }

diff --git a/t/06-want_at.t b/t/06-want_at.t
new file mode 100644 (file)
index 0000000..7d29d24
--- /dev/null
+++ b/t/06-want_at.t
@@ -0,0 +1,53 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+
+use Scope::Upper qw/want_at/;
+
+sub check {
+ my ($w, $exp, $desc) = @_;
+ my $cx = sub {
+  my $a = shift;
+  if (!defined $a) {
+   return 'void';
+  } elsif ($a) {
+   return 'list';
+  } else {
+   return 'scalar';
+  }
+ };
+ is $cx->($w), $cx->($exp), $desc;
+}
+
+my $w;
+
+check want_at,     undef, 'main : want_at';
+check want_at(0),  undef, 'main : want_at(0)';
+check want_at(1),  undef, 'main : want_at(1)';
+check want_at(-1), undef, 'main : want_at(-1)';
+
+my @a = sub {
+ check want_at, 1, 'sub0 : want_at';
+ {
+  check want_at,    1, 'sub : want_at';
+  check want_at(1), 1, 'sub : want_at(1)';
+  for (1) {
+   check want_at,    1, 'for : want_at';
+   check want_at(1), 1, 'for : want_at(1)';
+   check want_at(2), 1, 'for : want_at(2)';
+  }
+  my $x = eval {
+   do {
+    check want_at,    0, 'do : want_at';
+    check want_at(1), 0, 'do : want_at(0)';
+    check want_at(2), 1, 'do : want_at(1)';
+   };
+   check want_at,    0, 'eval : want_at';
+   check want_at(1), 1, 'eval : want_at(0)';
+   check want_at(2), 1, 'eval : want_at(1)';
+  };
+ }
+}->();