Implement leave()

diff --git a/Upper.xs b/Upper.xs
index 0d51f43925ba86c1823e3e3d447d508ab538a05f..eef2503e31c09d6ab9c26619e2a1d418fd0e9e6e 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -1119,6 +1119,7 @@ STATIC void su_unwind(pTHX_ void *ud_) {
 STATIC void su_yield(pTHX_ void *ud_) {
  dMY_CXT;
  PERL_CONTEXT *cx;
+ const char   *which = ud_;
  I32 cxix      = MY_CXT.yield_storage.cxix;
  I32 items     = MY_CXT.yield_storage.items;
  opcode  type  = OP_NULL;
@@ -1243,10 +1244,11 @@ cxt_when:
    break;
 #endif
   case CXt_SUBST:
-   croak("yield() cannot target a substitution context");
+   croak("%s() cannot target a substitution context", which);
    break;
   default:
-   croak("yield() don't know how to leave a %s context", SU_CXNAME(cxstack + cxix));
+   croak("%s() don't know how to leave a %s context",
+          which,                         SU_CXNAME(cxstack + cxix));
    break;
  }
 
@@ -2210,6 +2212,8 @@ XS(XS_Scope__Upper_unwind) {
  croak("Can't return outside a subroutine");
 }
 
+STATIC const char su_yield_name[] = "yield";
+
 XS(XS_Scope__Upper_yield); /* prototype to pass -Wmissing-prototypes */
 
 XS(XS_Scope__Upper_yield) {
@@ -2235,7 +2239,33 @@ XS(XS_Scope__Upper_yield) {
  /* See XS_Scope__Upper_unwind */
  if (GIMME_V == G_SCALAR)
   PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
- SAVEDESTRUCTOR_X(su_yield, NULL);
+ SAVEDESTRUCTOR_X(su_yield, su_yield_name);
+ return;
+}
+
+STATIC const char su_leave_name[] = "leave";
+
+XS(XS_Scope__Upper_leave); /* prototype to pass -Wmissing-prototypes */
+
+XS(XS_Scope__Upper_leave) {
+#ifdef dVAR
+ dVAR; dXSARGS;
+#else
+ dXSARGS;
+#endif
+ dMY_CXT;
+ I32 cxix;
+
+ PERL_UNUSED_VAR(cv); /* -W */
+ PERL_UNUSED_VAR(ax); /* -Wall */
+
+ MY_CXT.yield_storage.cxix   = su_context_here();
+ MY_CXT.yield_storage.items  = items;
+ MY_CXT.yield_storage.savesp = PL_stack_sp;
+ /* See XS_Scope__Upper_unwind */
+ if (GIMME_V == G_SCALAR)
+  PL_stack_sp = PL_stack_base + PL_markstack_ptr[1] + 1;
+ SAVEDESTRUCTOR_X(su_yield, su_leave_name);
  return;
 }
 
@@ -2258,6 +2288,7 @@ BOOT:
 
  newXSproto("Scope::Upper::unwind", XS_Scope__Upper_unwind, file, NULL);
  newXSproto("Scope::Upper::yield",  XS_Scope__Upper_yield,  file, NULL);
+ newXSproto("Scope::Upper::leave",  XS_Scope__Upper_leave,  file, NULL);
 
  su_setup();
 }

diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm
index 7ed86d8e68e09fa78377b57a58edde16678de4f9..4a9010059f7ce5112af17d57452539ae17458ff8 100644 (file)
--- a/lib/Scope/Upper.pm
+++ b/lib/Scope/Upper.pm
@@ -170,7 +170,7 @@ localize variables, array/hash values or deletions of elements in higher context
 
 =item *
 
-return values immediately to an upper level with L</unwind> and L</yield>, and know which context was in use then with L</want_at> ;
+return values immediately to an upper level with L</unwind>, L</yield> and L</leave>, and know which context was in use then with L</want_at> ;
 
 =item *
 
@@ -340,6 +340,14 @@ Hence you can use it to return values from a C<do> or a C<map> block :
 
 Like for L</unwind>, the upper context isn't coerced onto C<@values>.
 
+=head2 C<leave>
+
+    leave;
+    leave @values;
+
+Immediately returns C<@values> from the current block, whatever it may be (besides a C<s///e> substitution context).
+C<leave> is actually a synonym for C<unwind HERE>, while C<leave @values> is a synonym for C<yield @values, HERE>.
+
 =head2 C<want_at>
 
     my $want = want_at;
@@ -638,7 +646,7 @@ Where L</unwind>, L</yield>, L</want_at> and L</uplevel> point to depending on t
 
 =head1 EXPORT
 
-The functions L</reap>, L</localize>, L</localize_elem>, L</localize_delete>,  L</unwind>, L</yield>, L</want_at> and L</uplevel> 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>, L</yield>, L</leave>, L</want_at> and L</uplevel> are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>.
 
 The constant L</SU_THREADSAFE> is also only exported on request, individually or by the tags C<':consts'> and C<':all'>.
 
@@ -653,7 +661,7 @@ our %EXPORT_TAGS = (
  funcs  => [ qw<
   reap
   localize localize_elem localize_delete
-  unwind yield
+  unwind yield leave
   want_at
   uplevel
   uid validate_uid

diff --git a/t/01-import.t b/t/01-import.t
index dcd2525a7ab27f8fa6dfbff053675d36ee0ffef5..247470562e4fea918e6ff7edc63ff0dc889b427d 100644 (file)
--- a/t/01-import.t
+++ b/t/01-import.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 2 * 18;
+use Test::More tests => 2 * 19;
 
 require Scope::Upper;
 
@@ -14,6 +14,7 @@ my %syms = (
  localize_delete => '$$;$',
  unwind          => undef,
  yield           => undef,
+ leave           => undef,
  want_at         => ';$',
  uplevel         => '&@',
  uid             => ';$',

diff --git a/t/55-yield-target.t b/t/55-yield-target.t
index 594a04be93aa1f815dff46f7d92d846608c43e54..48b503626157e7eecc080ff2b6b5b33c61adb80b 100644 (file)
--- a/t/55-yield-target.t
+++ b/t/55-yield-target.t
@@ -5,7 +5,7 @@ use warnings;
 
 use Test::More tests => 18;
 
-use Scope::Upper qw<yield>;
+use Scope::Upper qw<yield leave>;
 
 my @res;
 

diff --git a/t/58-yield-misc.t b/t/58-yield-misc.t
index 23fc1d4967fc696dd1fcde037886db0ec52cc183..2eb222ff8e6c07a11715ff57bba2f9b2de2f2a63 100644 (file)
--- a/t/58-yield-misc.t
+++ b/t/58-yield-misc.t
@@ -3,12 +3,12 @@
 use strict;
 use warnings;
 
-use Test::More tests => 4 * 3;
+use Test::More tests => 4 * 3 + 3;
 
 use lib 't/lib';
 use VPIT::TestHelpers;
 
-use Scope::Upper qw<yield HERE>;
+use Scope::Upper qw<yield leave HERE>;
 
 # Test timely destruction of values returned from yield()
 
@@ -74,3 +74,34 @@ sub guard { VPIT::TestHelpers::Guard->new(sub { ++$destroyed }) }
  }
  is $destroyed, 1, "$desc: destroyed 2";
 }
+
+# Test leave
+
+{
+ my @res = (1, do {
+  leave;
+  'XXX';
+ }, 2);
+ is "@res", '1 2', 'leave without arguments';
+}
+
+{
+ my @res = (1, do {
+  leave 2, 3;
+  'XXX';
+ }, 4);
+ is "@res", '1 2 3 4', 'leave with arguments';
+}
+
+{
+ my $s = 'a';
+ local $@;
+ eval {
+  $s =~ s/./leave; die 'not reached'/e;
+ };
+ my $err  = $@;
+ my $line = __LINE__-3;
+ like $err,
+      qr/^leave\(\) cannot target a substitution context at \Q$0\E line $line/,
+      'leave() cannot exit subst';
+}