From: Vincent Pit <vince@profvince.com>
Date: Sun, 11 Jan 2009 11:17:33 +0000 (+0100)
Subject: Add unwind()
X-Git-Tag: v0.04~15
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=633ccd1999a16c7ccb9eda8d7668292f5b2a0a74

Add unwind()
---

diff --git a/MANIFEST b/MANIFEST
index 7913d05..da4fe1a 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -24,6 +24,7 @@ t/34-localize_elem-magic.t
 t/40-localize_delete-target.t
 t/41-localize_delete-level.t
 t/44-localize_delete-magic.t
+t/50-unwind-context.t
 t/81-stress-level.t
 t/90-boilerplate.t
 t/91-pod.t
diff --git a/Upper.xs b/Upper.xs
index bb90842..b7088ae 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -14,6 +14,10 @@
 
 /* --- Compatibility ------------------------------------------------------- */
 
+#ifndef PERL_UNUSED_VAR
+# define PERL_UNUSED_VAR(V)
+#endif
+
 #ifndef STMT_START
 # define STMT_START do
 #endif
@@ -536,8 +540,89 @@ done:
   XSRETURN_UNDEF;                          \
  } STMT_END
 
+typedef struct {
+ I32 cxix;
+ I32 items;
+} su_ud_unwind;
+
+STATIC void su_unwind(pTHX_ void *ud_) {
+ su_ud_unwind *ud = (su_ud_unwind *) ud_;
+ OP fakeop;
+ I32 cxix  = ud->cxix;
+ I32 items = ud->items - 1;
+ I32 gimme, mark = 0;
+
+ if (cxstack_ix > cxix)
+  dounwind(cxix);
+
+ /* Hide the level */
+ PL_stack_sp--;
+
+ gimme = GIMME_V;
+ if (cxix > 0)
+  mark = cxstack[cxix - 1].blk_oldsp;
+
+ if (gimme == G_SCALAR) {
+  *PL_markstack_ptr = PL_stack_sp - PL_stack_base;
+  PL_stack_sp += items;
+ } else {
+  *PL_markstack_ptr = PL_stack_sp - PL_stack_base - items;
+ }
+
+ PL_op = PL_ppaddr[OP_RETURN](aTHX);
+ *PL_markstack_ptr = mark;
+
+ fakeop.op_next = PL_op;
+ PL_op = &fakeop;
+
+ Safefree(ud);
+}
+
 /* --- XS ------------------------------------------------------------------ */
 
+XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */
+
+XS(XS_Scope__Upper_unwind) {
+#ifdef dVAR
+ dVAR; dXSARGS;
+#else
+ dXSARGS;
+#endif
+ I32 cxix;
+ su_ud_unwind *ud;
+ SV *level;
+ if (!items)
+  Perl_croak(aTHX_ "Usage: Scope::Upper::unwind(..., level)");
+ PERL_UNUSED_VAR(cv); /* -W */
+ PERL_UNUSED_VAR(ax); /* -Wall */
+ level = ST(items - 1);
+ cxix = SvOK(level) ? SvIV(level) : 0;
+ if (cxix < 0)
+  cxix = 0;
+ else if (cxix > cxstack_ix)
+  cxix = cxstack_ix;
+ cxix = cxstack_ix - cxix;
+ do {
+  PERL_CONTEXT *cx = cxstack + cxix;
+  switch (CxTYPE(cx)) {
+   case CXt_SUB:
+   case CXt_EVAL:
+   case CXt_FORMAT:
+    /* pp_entersub will try to sanitize the stack - screw that, we're insane */
+    if (GIMME_V == G_SCALAR)
+     PL_stack_sp = PL_stack_base + TOPMARK + 1;
+    Newx(ud, 1, su_ud_unwind);
+    ud->cxix  = cxix;
+    ud->items = items;
+    SAVEDESTRUCTOR_X(su_unwind, ud);
+    return;
+   default:
+    break;
+  }
+ } while (--cxix >= 0);
+ croak("Can't return outside a subroutine");
+}
+
 MODULE = Scope::Upper            PACKAGE = Scope::Upper
 
 PROTOTYPES: ENABLE
@@ -546,6 +631,7 @@ BOOT:
 {
  HV *stash = gv_stashpv(__PACKAGE__, 1);
  newCONSTSUB(stash, "HERE", newSViv(0));
+ newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
 }
 
 SV *
diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm
index ca8ecc9..259ee7f 100644
--- a/lib/Scope/Upper.pm
+++ b/lib/Scope/Upper.pm
@@ -136,6 +136,11 @@ C<$key> is ignored.
 
 =back
 
+=head2 C<unwind @values, $level>
+
+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.
+
 =head1 WORDS
 
 =head2 C<TOP>
@@ -166,7 +171,7 @@ If C<$from> is omitted in any of those functions, the current level is used as t
 
 =head1 EXPORT
 
-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'>.
+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'>.
 
@@ -176,7 +181,7 @@ use base qw/Exporter/;
 
 our @EXPORT      = ();
 our %EXPORT_TAGS = (
- funcs => [ qw/reap localize localize_elem localize_delete/ ],
+ funcs => [ qw/reap localize localize_elem localize_delete unwind/ ],
  words => [ qw/TOP HERE UP DOWN SUB EVAL/ ],
 );
 our @EXPORT_OK   = map { @$_ } values %EXPORT_TAGS;
diff --git a/t/01-import.t b/t/01-import.t
index b1c2b17..06c02b3 100644
--- a/t/01-import.t
+++ b/t/01-import.t
@@ -3,11 +3,11 @@
 use strict;
 use warnings;
 
-use Test::More tests => 10;
+use Test::More tests => 11;
 
 require Scope::Upper;
 
-for (qw/reap localize localize_elem localize_delete TOP HERE UP DOWN SUB EVAL/) {
+for (qw/reap localize localize_elem localize_delete unwind TOP HERE UP DOWN SUB EVAL/) {
  eval { Scope::Upper->import($_) };
  is($@, '', 'import ' . $_);
 }
diff --git a/t/50-unwind-context.t b/t/50-unwind-context.t
new file mode 100644
index 0000000..bd783cf
--- /dev/null
+++ b/t/50-unwind-context.t
@@ -0,0 +1,245 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 29;
+
+use Scope::Upper qw/unwind SUB/;
+
+my ($res, @res);
+
+# --- Void to void ------------------------------------------------------------
+
+sub {
+ $res = 1;
+ unwind(qw/a b c/ => SUB);
+ $res = 0;
+}->(0);
+ok $res, 'unwind in void context at sub to void';
+
+sub {
+ $res = 1;
+ eval {
+  unwind(qw/d e f/ => SUB);
+ };
+ $res = 0;
+}->(0);
+ok $res, 'unwind in void context at sub across eval to void';
+
+sub {
+ $res = 1;
+ for (1 .. 5) {
+  unwind qw/g h i/ => SUB;
+ }
+ $res = 0;
+}->(0);
+ok $res, 'unwind in void context at sub across loop to void';
+
+# --- Void to scalar ----------------------------------------------------------
+
+$res = sub {
+ unwind(qw/a b c/ => SUB);
+ return 'XXX';
+}->(0);
+is $res, 'c', 'unwind in void context at sub to scalar';
+
+$res = sub {
+ eval {
+  unwind qw/d e f/ => SUB;
+ };
+ return 'XXX';
+}->(0);
+is $res, 'f', 'unwind in void context at sub across eval to scalar';
+
+$res = sub {
+ for (1 .. 5) {
+  unwind qw/g h i/ => SUB;
+ }
+}->(0);
+is $res, 'i', 'unwind in void context at sub across loop to scalar';
+
+$res = sub {
+ for (6, unwind qw/j k l/ => SUB) {
+  $res = 'NO';
+ }
+ return 'XXX';
+}->(0);
+is $res, 'l', 'unwind in void context at sub across loop iterator to scalar';
+
+# --- Void to list ------------------------------------------------------------
+
+@res = sub {
+ unwind qw/a b c/ => SUB;
+ return 'XXX';
+}->(0);
+is_deeply \@res, [ qw/a b c/ ], 'unwind in void context at sub to list';
+
+@res = sub {
+ eval {
+  unwind qw/d e f/ => SUB;
+ };
+ return 'XXX';
+}->(0);
+is_deeply \@res, [ qw/d e f/ ], 'unwind in void context at sub across eval to list';
+
+@res = sub {
+ for (1 .. 5) {
+  unwind qw/g h i/ => SUB;
+ }
+}->(0);
+is_deeply \@res, [ qw/g h i/ ], 'unwind in void context at sub across loop to list';
+
+# --- Scalar to void ----------------------------------------------------------
+
+sub {
+ $res = 1;
+ my $temp = unwind(qw/a b c/ => SUB);
+ $res = 0;
+}->(0);
+ok $res, 'unwind in scalar context at sub to void';
+
+sub {
+ $res = 1;
+ my $temp = eval {
+  unwind(qw/d e f/ => SUB);
+ };
+ $res = 0;
+}->(0);
+ok $res, 'unwind in scalar context at sub across eval to void';
+
+sub {
+ $res = 1;
+ for (1 .. 5) {
+  my $temp = (unwind qw/g h i/ => SUB);
+ }
+ $res = 0;
+}->(0);
+ok $res, 'unwind in scalar context at sub across loop to void';
+
+sub {
+ $res = 1;
+ if (unwind qw/m n o/ => SUB) {
+  $res = undef;
+ }
+ $res = 0;
+}->(0);
+ok $res, 'unwind in scalar context at sub across test to void';
+
+# --- Scalar to scalar --------------------------------------------------------
+
+$res = sub {
+ 1, unwind(qw/a b c/ => SUB);
+}->(0);
+is $res, 'c', 'unwind in scalar context at sub to scalar';
+
+$res = sub {
+ eval {
+  8, unwind qw/d e f/ => SUB;
+ };
+}->(0);
+is $res, 'f', 'unwind in scalar context at sub across eval to scalar';
+
+$res = sub {
+ if (unwind qw/m n o/ => SUB) {
+  return 'XXX';
+ }
+}->(0);
+is $res, 'o', 'unwind in scalar context at sub across test to scalar';
+
+# --- Scalar to list ----------------------------------------------------------
+
+@res = sub {
+ if (unwind qw/m n o/ => SUB) {
+  return 'XXX';
+ }
+}->(0);
+is_deeply \@res, [ qw/m n o/ ], 'unwind in scalar context at sub across test to list';
+
+# --- List to void ------------------------------------------------------------
+
+sub {
+ $res = 1;
+ my @temp = unwind(qw/a b c/ => SUB);
+ $res = 0;
+}->(0);
+ok $res, 'unwind in list context at sub to void';
+
+sub {
+ $res = 1;
+ my @temp = eval {
+  unwind(qw/d e f/ => SUB);
+ };
+ $res = 0;
+}->(0);
+ok $res, 'unwind in list context at sub across eval to void';
+
+sub {
+ $res = 1;
+ for (1 .. 5) {
+  my @temp = (unwind qw/g h i/ => SUB);
+ }
+ $res = 0;
+}->(0);
+ok $res, 'unwind in list context at sub across loop to void';
+
+sub {
+ $res = 1;
+ for (6, unwind qw/j k l/ => SUB) {
+  $res = undef;
+ }
+ $res = 0;
+}->(0);
+ok $res, 'unwind in list context at sub across test to void';
+
+# --- List to scalar ----------------------------------------------------------
+
+$res = sub {
+ my @temp = (1, unwind(qw/a b c/ => SUB));
+ return 'XXX';
+}->(0);
+is $res, 'c', 'unwind in list context at sub to scalar';
+
+$res = sub {
+ my @temp = eval {
+  8, unwind qw/d e f/ => SUB;
+ };
+ return 'XXX';
+}->(0);
+is $res, 'f', 'unwind in list context at sub across eval to scalar';
+
+$res = sub {
+ for (1 .. 5) {
+  my @temp = (7, unwind qw/g h i/ => SUB);
+ }
+ return 'XXX';
+}->(0);
+is $res, 'i', 'unwind in list context at sub across loop to scalar';
+
+$res = sub {
+ for (6, unwind qw/j k l/ => SUB) {
+  return 'XXX';
+ }
+}->(0);
+is $res, 'l', 'unwind in list context at sub across loop iterator to scalar';
+
+# --- List to list ------------------------------------------------------------
+
+@res = sub {
+ 2, unwind qw/a b c/ => SUB;
+}->(0);
+is_deeply \@res, [ qw/a b c/ ], 'unwind in list context at sub to list';
+
+@res = sub {
+ eval {
+  8, unwind qw/d e f/ => SUB;
+ };
+}->(0);
+is_deeply \@res, [ qw/d e f/ ], 'unwind in list context at sub across eval to list';
+
+@res = sub {
+ for (6, unwind qw/j k l/ => SUB) {
+  return 'XXX';
+ }
+}->(0);
+is_deeply \@res, [ qw/j k l/ ], 'unwind in list context at sub across loop iterator to list';