Fix uplevel() recalling into an XSUB

diff --git a/Upper.xs b/Upper.xs
index 3266a4293379818ed16a9c417eca37c0ea2bf207..a50c576e197a2255865d896d3ddc476e301c025c 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -1205,10 +1205,15 @@ STATIC CV *su_cv_clone(pTHX_ CV *proto, GV *gv) {
   Perl_sv_add_backref(aTHX_ CvSTASH(proto), MUTABLE_SV(cv));
 #endif
 
- OP_REFCNT_LOCK;
- CvROOT(cv)        = OpREFCNT_inc(CvROOT(proto));
- OP_REFCNT_UNLOCK;
- CvSTART(cv)       = CvSTART(proto);
+ if (CvISXSUB(proto)) {
+  CvXSUB(cv)       = CvXSUB(proto);
+  CvXSUBANY(cv)    = CvXSUBANY(proto);
+ } else {
+  OP_REFCNT_LOCK;
+  CvROOT(cv)       = OpREFCNT_inc(CvROOT(proto));
+  OP_REFCNT_UNLOCK;
+  CvSTART(cv)      = CvSTART(proto);
+ }
  CvOUTSIDE(cv)     = CvOUTSIDE(proto);
 #ifdef CVf_WEAKOUTSIDE
  if (!(CvFLAGS(proto) & CVf_WEAKOUTSIDE))
@@ -1492,6 +1497,9 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
  if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) {
   PERL_CONTEXT *sub_cx = cxstack + cxstack_ix;
 
+  /* If pp_entersub() returns a non-null OP, it means that the callback is not
+   * an XSUB. */
+
   sud->callback = MUTABLE_CV(SvREFCNT_inc(callback));
   CvDEPTH(callback)++;
 
@@ -1516,14 +1524,11 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
   SAVEDESTRUCTOR_X(su_uplevel_goto_handler, sud);
 
   CALLRUNOPS(aTHX);
-
-  ret = PL_stack_sp - (PL_stack_base + new_mark);
  }
 
  sud->died = 0;
 
- SPAGAIN;
-
+ ret = PL_stack_sp - (PL_stack_base + new_mark);
  if (ret > 0) {
   AV *old_stack = sud->old_curstackinfo->si_stack;
 
@@ -1538,8 +1543,6 @@ STATIC I32 su_uplevel(pTHX_ CV *callback, I32 cxix, I32 args) {
   AvFILLp(old_stack) += ret;
  }
 
- PUTBACK;
-
  LEAVE;
 
  return ret;

diff --git a/t/60-uplevel-target.t b/t/60-uplevel-target.t
index c605299bcf8d1efadecc3f2814b20640cdbd4bd3..87444ba701299b695bd5c26f26096a04ccf5eafb 100644 (file)
--- a/t/60-uplevel-target.t
+++ b/t/60-uplevel-target.t
@@ -3,7 +3,8 @@
 use strict;
 use warnings;
 
-use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5 + 6 + 5;
+use Test::More
+             tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 7 + (5 + 6 + 5 + 6 + 5);
 
 use Scope::Upper qw<uplevel HERE UP TOP>;
 
@@ -120,6 +121,39 @@ sub four {
  like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
 }
 
+# XS
+
+{
+ my $desc = 'uplevel to XS 1';
+ local $@;
+ eval {
+  sub {
+   my $cxt = HERE;
+   pass "$desc: before";
+   &uplevel(\&HERE => $cxt);
+   is HERE, $cxt, "$desc: after";
+  }->();
+ };
+ is $@, '', "$desc: no error";
+}
+
+{
+ my $desc = 'uplevel to XS 1';
+ local $@;
+ eval {
+  sub {
+   my $up = HERE;
+   sub {
+    is UP, $up, "$desc: before";
+    &uplevel(\&HERE => $up);
+    isnt HERE, $up, "$desc: after 1";
+   }->();
+   is HERE, $up, "$desc: after 2";
+  }->();
+ };
+ is $@, '', "$desc: no error";
+}
+
 # Target destruction
 
 {

diff --git a/t/61-uplevel-args.t b/t/61-uplevel-args.t
index 59a9071fe0e5370d6671680781959ce2a664de5c..f6955adfbf821339eb798ef3ee8b3c9ffdfd67b9 100644 (file)
--- a/t/61-uplevel-args.t
+++ b/t/61-uplevel-args.t
@@ -3,9 +3,9 @@
 use strict;
 use warnings;
 
-use Test::More tests => 9 + 4 * 7 + 3 + ((5 * 4 * 4) * 3 + 1) + 2 + 6;
+use Test::More tests => 9 + 4 * 7 + 3 + ((5 * 4 * 4) * 3 + 1) + 3 + 2 + 6;
 
-use Scope::Upper qw<uplevel HERE>;
+use Scope::Upper qw<uplevel HERE UP>;
 
 # Basic
 
@@ -233,6 +233,29 @@ SKIP: {
  }->('dummy');
 }
 
+# uplevel() to uplevel()
+
+{
+ my $desc = '\&uplevel as the uplevel() callback';
+ local $@;
+ eval {
+  sub {
+   my $cxt = HERE;
+   sub {
+    sub {
+     # Note that an XS call does not need a context, so after the first uplevel
+     # call UP will point to the scope above the first target.
+     uplevel(\&uplevel => (sub {
+      is "@_", '1 2 3', "$desc: arguments inisde";
+      is HERE, $cxt,    "$desc: context inside";
+     } => 1 .. 3 => UP) => UP);
+    }->(10 .. 19);
+   }->(sub { die 'wut' } => HERE);
+  }->('dummy');
+ };
+ is $@, '', "$desc: no error";
+}
+
 # Magic
 
 {

diff --git a/t/62-uplevel-return.t b/t/62-uplevel-return.t
index ff4df578b01d82b06a43b440b5bd15a94fddb1c7..89bc22aed353a8b9dd082aba2bdbce89d1ade1a0 100644 (file)
--- a/t/62-uplevel-return.t
+++ b/t/62-uplevel-return.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => (13 + 5 + 4) * 2 + 1 + (3 + 3 + 1) + 2 + 11;
+use Test::More tests => (13 + 5 + 4) * 2 + 1 + (3 + 3 + 1) + 2 + 4 + 11;
 
 use Scope::Upper qw<uplevel HERE UP>;
 
@@ -173,6 +173,33 @@ SKIP: {
  }
 }
 
+# uplevel() to uplevel()
+
+{
+ my $desc = '\&uplevel as the uplevel() callback';
+ local $@;
+ eval {
+  my @ret = sub {
+   my $cxt = HERE;
+   my @ret = sub {
+    my @ret = sub {
+     # Note that an XS call does not need a context, so after the first uplevel
+     # call UP will point to the scope above the first target.
+     'a', uplevel(\&uplevel => (sub {
+      return qw<x y z>;
+     } => UP) => UP), 'b';
+    }->();
+    is "@ret", 'a x y z b', "$desc: returned from uplevel";
+    return qw<u v w>;
+   }->();
+   is "@ret", 'u v w', "$desc: returned from the first target";
+   return qw<m n>;
+  }->();
+  is "@ret", 'm n', "$desc: returned from the second target";
+ };
+ is $@, '', "$desc: no error";
+}
+
 # Magic
 
 {

diff --git a/t/63-uplevel-ctl.t b/t/63-uplevel-ctl.t
index 645d6f89439b2ccf4f943ab28d93675f6d581243..4f031bce414ef403fa3127dab8280810fc4129a5 100644 (file)
--- a/t/63-uplevel-ctl.t
+++ b/t/63-uplevel-ctl.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 3 + (3 + 4 + 4) + (3 + 4 + 4) + 5 + 3*3 + (4 + 7);
+use Test::More tests => 3 + (3 + 4 + 4) + (3 + 4 + 4) + 5 + 3*3 + (4 + 7) + 1;
 
 use Scope::Upper qw<uplevel HERE SUB CALLER>;
 
@@ -307,3 +307,19 @@ sub clash {
  is $@, '', "$desc: no exception outside";
  check_depth \&clash, 0, "$desc: depth at the beginning";
 }
+
+# XS
+
+{
+ my $desc = 'exception thrown from XS';
+ local $@;
+ eval {
+  sub {
+   &uplevel(\&uplevel => \1, HERE);
+  }->();
+ };
+ my $line = __LINE__-2; # The error happens at the target frame.
+ like $@,
+   qr/^First argument to uplevel must be a code reference at \Q$0\E line $line/,
+   "$desc: correct error";
+}