Preserve lexicals across dounwind() calls on perl 5.19.4 and above

unwind() used to rely on the stack being preserved when dounwind() is
called. However, starting with change 25375124, dounwind() can now call
leave_scope() which will clean up lexicals in the unwinded scopes. We
can work around this by temporarily bumping the refcount of possibly
problematic scalars before calling dounwind().

See also https://rt.perl.org/rt3/Ticket/Display.html?id=119681.

diff --git a/MANIFEST b/MANIFEST
index 9e437bbca7755a2b8de0fbc2b0af9160afb5da65..7004ef047bff456d766be2b9197849891c244ad4 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -38,6 +38,7 @@ t/46-localize_delete-numerous.t
 t/50-unwind-target.t
 t/51-unwind-multi.t
 t/52-unwind-context.t
+t/53-unwind-misc.t
 t/54-unwind-threads.t
 t/55-yield-target.t
 t/57-yield-context.t

diff --git a/Upper.xs b/Upper.xs
index 46dc5931efb657df2f86da4ca689cb5e48ed4ffa..eb45c1f5faa2d3e2dfdddf5236c6695ed6eb7b59 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -1126,6 +1126,15 @@ STATIC void su_unwind(pTHX_ void *ud_) {
  PERL_UNUSED_VAR(ud_);
 
  PL_stack_sp = MY_CXT.unwind_storage.savesp;
+#if SU_HAS_PERL(5, 19, 4)
+ {
+  I32 i;
+  SV **sp = PL_stack_sp;
+  for (i = -items + 1; i <= 0; ++i)
+   if (!SvTEMP(sp[i]))
+    sv_2mortal(SvREFCNT_inc(sp[i]));
+ }
+#endif
 
  if (cxstack_ix > cxix)
   dounwind(cxix);
@@ -1301,6 +1310,15 @@ cxt_when:
  }
 
  PL_stack_sp = MY_CXT.yield_storage.savesp;
+#if SU_HAS_PERL(5, 19, 4)
+ {
+  I32 i;
+  SV **sp = PL_stack_sp;
+  for (i = -items + 1; i <= 0; ++i)
+   if (!SvTEMP(sp[i]))
+    sv_2mortal(SvREFCNT_inc(sp[i]));
+ }
+#endif
 
  if (cxstack_ix > cxix)
   dounwind(cxix);

diff --git a/t/53-unwind-misc.t b/t/53-unwind-misc.t
new file mode 100644 (file)
index 0000000..44ecbe4
--- /dev/null
+++ b/t/53-unwind-misc.t
@@ -0,0 +1,54 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+use Scope::Upper qw<unwind UP SUB>;
+
+{
+ my @destroyed;
+
+ {
+  package Scope::Upper::TestTimelyDestruction;
+
+  sub new {
+   my ($class, $label) = @_;
+   bless { label => $label }, $class;
+  }
+
+  sub label { $_[0]->{label} }
+
+  sub DESTROY {
+   push @destroyed, $_[0]->label;
+  }
+ }
+
+ sub SU_TTD () { 'Scope::Upper::TestTimelyDestruction' }
+
+ sub foo {
+  my $r = SU_TTD->new('a');
+  my @x = (SU_TTD->new('c'), SU_TTD->new('d'));
+  unwind 123, $r, SU_TTD->new('b'), @x, sub { SU_TTD->new('e') }->() => UP SUB;
+ }
+
+ sub bar {
+  foo();
+  die 'not reached';
+ }
+
+ {
+  my $desc = sub { "unwinding @_ across a sub" };
+  my @res = bar();
+  is $res[0],        123, $desc->('a constant literal');
+  is $res[1]->label, 'a', $desc->('a lexical');
+  is $res[2]->label, 'b', $desc->('a temporary object');
+  is $res[3]->label, 'c', $desc->('the contents of a lexical array (1)');
+  is $res[4]->label, 'd', $desc->('the contents of a lexical array (2)');
+  is $res[5]->label, 'e', $desc->('a temporary object returned by a sub');
+ }
+
+ is_deeply \@destroyed, [ qw<e d c b a> ],
+                                    'all these objects were properly destroyed';
+}

diff --git a/t/58-yield-misc.t b/t/58-yield-misc.t
index 3243272da8fcd30f8383803de941d568717ca0a4..e89e8926ceb5cbac39232c04f780d14b6e0b4780 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 + 1 + 3;
+use Test::More tests => 4 * 3 + 1 + 3 + 7;
 
 use lib 't/lib';
 use VPIT::TestHelpers;
 
-use Scope::Upper qw<yield leave HERE>;
+use Scope::Upper qw<yield leave HERE UP SUB>;
 
 # Test timely destruction of values returned from yield()
 
@@ -135,3 +135,49 @@ SKIP: {
       qr/^leave\(\) can't target a substitution context at \Q$0\E line $line/,
       'leave() cannot exit subst';
 }
+
+{
+ my @destroyed;
+
+ {
+  package Scope::Upper::TestTimelyDestruction;
+
+  sub new {
+   my ($class, $label) = @_;
+   bless { label => $label }, $class;
+  }
+
+  sub label { $_[0]->{label} }
+
+  sub DESTROY {
+   push @destroyed, $_[0]->label;
+  }
+ }
+
+ sub SU_TTD () { 'Scope::Upper::TestTimelyDestruction' }
+
+ sub foo {
+  my $r = SU_TTD->new('a');
+  my @x = (SU_TTD->new('c'), SU_TTD->new('d'));
+  yield 123, $r, SU_TTD->new('b'), @x, sub { SU_TTD->new('e') }->() => UP SUB;
+ }
+
+ sub bar {
+  foo();
+  die 'not reached';
+ }
+
+ {
+  my $desc = sub { "yielding @_ across a sub" };
+  my @res = bar();
+  is $res[0],        123, $desc->('a constant literal');
+  is $res[1]->label, 'a', $desc->('a lexical');
+  is $res[2]->label, 'b', $desc->('a temporary object');
+  is $res[3]->label, 'c', $desc->('the contents of a lexical array (1)');
+  is $res[4]->label, 'd', $desc->('the contents of a lexical array (2)');
+  is $res[5]->label, 'e', $desc->('a temporary object returned by a sub');
+ }
+
+ is_deeply \@destroyed, [ qw<e d c b a> ],
+                                    'all these objects were properly destroyed';
+}