Don’t let reblessing point SvSTASH to a half-freed stash

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.

diff --git a/sv.c b/sv.c
index 804f8e9..741dcda 100644 (file)
--- 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 (file)
--- 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'
+}