[perl #117941] Blessing into freed current stash

If the current stash has been freed, bless() with one argument will
cause a crash when the object’s ‘stash’ is accessed.  Simply disallow-
ing this is the easiest fix.

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 86e1b46..ff922fb 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -259,6 +259,12 @@ thread.  See L<threads>.
 (F) The failing code has attempted to get or set a key which is not in
 the current set of allowed keys of a restricted hash.
 
+=item Attempt to bless into a freed package
+
+(F) You wrote C<bless $foo> with one argument after somehow causing
+the current package to be freed.  Perl cannot figure out what to
+do, so it throws up in hands in despair.
+
 =item Attempt to bless into a reference
 
 (F) The CLASSNAME argument to the bless() operator is expected to be

diff --git a/pp.c b/pp.c
index 0367023..e63c342 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -607,8 +607,12 @@ PP(pp_bless)
     HV *stash;
 
     if (MAXARG == 1)
+    {
       curstash:
        stash = CopSTASH(PL_curcop);
+       if (SvTYPE(stash) != SVt_PVHV)
+           Perl_croak(aTHX_ "Attempt to bless into a freed package");
+    }
     else {
        SV * const ssv = POPs;
        STRLEN len;

diff --git a/t/op/bless.t b/t/op/bless.t
index 7ed3d43..801e985 100644 (file)
--- a/t/op/bless.t
+++ b/t/op/bless.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan (109);
+plan (110);
 
 sub expected {
     my($object, $package, $type) = @_;
@@ -142,3 +142,9 @@ expected($c4, 'C4', "SCALAR");
 
 bless [], "main::";
 ok(1, 'blessing into main:: does not crash'); # [perl #87388]
+
+sub _117941 { package _117941; bless [] }
+delete $::{"_117941::"};
+eval { _117941() };
+like $@, qr/^Attempt to bless into a freed package at /,
+        'bless with one arg when current stash is freed';