From: Vincent Pit <vince@profvince.com>
Date: Mon, 9 Sep 2013 17:07:53 +0000 (+0200)
Subject: Preserve lexicals across dounwind() calls on perl 5.19.4 and above
X-Git-Tag: v0.24~1
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=75dce157fb6b369c19c2dabc7de370feb0a79ae5;p=perl%2Fmodules%2FScope-Upper.git

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 9e437bb..7004ef0 100644
--- 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 46dc593..eb45c1f 100644
--- 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
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 3243272..e89e892 100644
--- 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';
+}