From 64e070a9f2155f9a1855e3268a31fa1d166251c8 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 8 Sep 2013 23:05:40 -0700
Subject: [PATCH] =?utf8?q?Don=E2=80=99t=20let=20reblessing=20point=20SvSTA?=
 =?utf8?q?SH=20to=20a=20half-freed=20stash?=
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

We should set SvSTASH before calling SvREFCNT_dec on its old value,
otherwise we could free the old stash and trigger a DESTROY that sees
the object blessed into the half-freed stash.

Currently, a second call to bless inside DESTROY can trigger ‘Attempt
to free unreferenced scalar’, because it calls SvREFCNT_dec a second
time on the stash that already has a reference count of 0.
---
 sv.c         |  4 +++-
 t/op/bless.t | 20 +++++++++++++++++++-
 2 files changed, 22 insertions(+), 2 deletions(-)

diff --git a/sv.c b/sv.c
index 804f8e9..741dcda 100644
--- a/sv.c
+++ b/sv.c
@@ -9811,6 +9811,7 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
 {
     dVAR;
     SV *tmpRef;
+    HV *oldstash = NULL;
 
     PERL_ARGS_ASSERT_SV_BLESS;
 
@@ -9822,12 +9823,13 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
 	if (SvREADONLY(tmpRef))
 	    Perl_croak_no_modify();
 	if (SvOBJECT(tmpRef)) {
-	    SvREFCNT_dec(SvSTASH(tmpRef));
+	    oldstash = SvSTASH(tmpRef);
 	}
     }
     SvOBJECT_on(tmpRef);
     SvUPGRADE(tmpRef, SVt_PVMG);
     SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
+    SvREFCNT_dec(oldstash);
 
     if(SvSMAGICAL(tmpRef))
         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
diff --git a/t/op/bless.t b/t/op/bless.t
index 4ab3e56..2f19d8d 100644
--- a/t/op/bless.t
+++ b/t/op/bless.t
@@ -6,7 +6,8 @@ BEGIN {
     require './test.pl';
 }
 
-plan (112);
+plan (114);
+# Please do not eliminate the plan.  We have tests in DESTROY blocks.
 
 sub expected {
     my($object, $package, $type) = @_;
@@ -160,3 +161,20 @@ sub FETCH { ${$_[0]} }
 tie $tied, main => $untied = [];
 eval { bless $tied };
 is ref $untied, "main", 'blessing through tied refs' or diag $@;
+
+bless \$victim, "Food";
+eval 'bless \$Food::bard, "Bard"';
+sub Bard::DESTROY {
+    isnt ref(\$victim), '__ANON__',
+        'reblessing does not leave an object in limbo temporarily';
+    bless \$victim
+}
+undef *Food::;
+{
+    my $w;
+    # This should catch ‘Attempt to free unreferenced scalar’.
+    local $SIG{__WARN__} = sub { $w .= shift };
+    bless \$victim;
+    is $w, undef,
+       'no warnings when reblessing inside DESTROY triggered by reblessing'
+}
-- 
2.7.4