Show quoted text> The patch is probably not good enough. I see now segfaults or errors
> while running the Method-Slice-0.02 test suite:
>
> Attempt to free unreferenced scalar: SV 0x40be46c0 at
> /usr/perl5.23.8sp/lib/site_perl/5.23.8/amd64-freebsd/Want.pm line 182.
Running with a debugging perl-5.23.8 will show assertion failures in the Want test suite. It's because PL_comppad/PL_curpad save/restore is now done by the context stack / cx_popsub() rather than as previously on the savestack / LEAVE.
This stops the double_return() 'convert CXt_SUB to CXt_NULL' hack from working properly, as PL_comppad is no longer restored when transitioning from the inner to outer sub. The attached patch substitutes one evil hack for another: it keeps the CXt_SUB context stack entry, but sets its retop field to point to the return op again (rather than its caller) so that the return op gets called twice (with a bit of markstack hackery to ensure there are two marks for the two returns to pop).
rreturn and lnoreturn are also a bit under-tested. In particular, there are no tests for rreturn in list context. I added such a test, but more need adding.
I can see this hack breaking again in the future. Perhaps in the long term
rreturn() and lnoreturn() should be implemented using custom ops???
Dave M.
From fb79291956dc7b14ea6882ae83b7eb4c62997fd1 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Thu, 25 Feb 2016 12:03:48 +0000
Subject: [PATCH] fix Want to work under perl 5.23.8+
PL_comppad is now saved in the context stack, so just CXt_NULLing out
the caller CXt_SUB frame to force a double return won't work any more.
---
Want-0.26/Want.pm | 8 +++-----
Want-0.26/Want.xs | 22 +++++++++++++++++++---
Want-0.26/t/all.t | 19 ++++++++++++++++++-
3 files changed, 40 insertions(+), 9 deletions(-)
diff --git a/Want-0.26/Want.pm b/Want-0.26/Want.pm
index 09eb592..2455adb 100644
--- a/Want-0.26/Want.pm
+++ b/Want-0.26/Want.pm
@@ -172,29 +172,27 @@ sub rreturn (@) {
if (want_lvalue(1)) {
croak "Can't rreturn in lvalue context";
}
- double_return();
# Extra scope needed to work with perl-5.19.7 or greater.
# Prevents the return being optimised out, which is needed
# since it's actually going to be used a stack level above
# this sub.
{
- return wantarray ? @_ : $_[$#_];
+ return double_return(@_);
}
}
-sub lnoreturn () {
+sub lnoreturn () : lvalue {
if (!want_lvalue(1) || !want_assign(1)) {
croak "Can't lnoreturn except in ASSIGN context";
}
- double_return();
# Extra scope needed to work with perl-5.19.7 or greater.
# Prevents the return being optimised out, which is needed
# since it's actually going to be used a stack level above
# this sub.
{
- return disarm_temp(my $undef);
+ return double_return(disarm_temp(my $undef));
}
}
diff --git a/Want-0.26/Want.xs b/Want-0.26/Want.xs
index ba247b5..faad857 100644
--- a/Want-0.26/Want.xs
+++ b/Want-0.26/Want.xs
@@ -723,7 +723,7 @@ U32 uplevel;
PUSHs(r ? sv_2mortal(newRV_noinc((SV*) r)) : &PL_sv_undef);
void
-double_return()
+double_return(...)
PREINIT:
PERL_CONTEXT *ourcx, *cx;
PPCODE:
@@ -731,12 +731,28 @@ double_return()
cx = upcontext(aTHX_ 1);
if (!cx)
Perl_croak(aTHX_ "Can't return outside a subroutine");
-
+#ifdef POPBLOCK
ourcx->cx_type = CXt_NULL;
CvDEPTH(ourcx->blk_sub.cv)--;
-#if HAS_RETSTACK
+# if HAS_RETSTACK
if (PL_retstack_ix > 0)
--PL_retstack_ix;
+# endif
+#else
+ /* In 5.23.8 or later, PL_curpad is saved in the context stack and
+ * restored by cx_popsub(), rather than being saved on the savestack
+ * and restored by LEAVE; so just CXt_NULLing the parent sub
+ * skips the PL_curpad restore and so everything done during the
+ * second part of the return will have the wrong PL_curpad.
+ * So instead, fix up the first return so that it thinks the
+ * op to continue at is iteself, forcing it to do a double return.
+ */
+ assert(PL_op->op_next->op_type == OP_RETURN);
+ /* force the op following the 'return' to be 'return' again */
+ ourcx->blk_sub.retop = PL_op->op_next;
+ assert(PL_markstack + ourcx->blk_oldmarksp + 1 == PL_markstack_ptr);
+ ourcx->blk_oldmarksp++;
+ ourcx->blk_gimme = cx->blk_gimme;
#endif
return;
diff --git a/Want-0.26/t/all.t b/Want-0.26/t/all.t
index 434c8f0..3d525f1 100644
--- a/Want-0.26/t/all.t
+++ b/Want-0.26/t/all.t
@@ -1,4 +1,4 @@
-BEGIN { $| = 1; print "1..70\n"; }
+BEGIN { $| = 1; print "1..72\n"; }
# Test that we can load the module
END {print "not ok 1\n" unless $loaded;}
@@ -223,3 +223,20 @@ my %x = tCOUNT(67, undef);
%x = (a => 1, tCOUNT(69, undef));
%::x = (a => 2, tCOUNT(70, undef));
+
+sub try_rreturn : lvalue {
+ rreturn @_;
+ return;
+}
+
+{
+ my $res;
+
+ $res = try_rreturn(qw(a b c));
+ print "not " unless $res eq "c";
+ print "ok 71 # rreturn in scalar context ($res)\n";
+
+ $res = join(':', try_rreturn(qw(a b c)));
+ print "not " unless $res eq "a:b:c";
+ print "ok 72 # rreturn in list context ($res)\n";
+}
--
2.4.3
