This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Dont’t crash when warning about XSUB redefinition
authorFather Chrysostomos <sprout@cpan.org>
Sat, 8 Oct 2011 20:02:46 +0000 (13:02 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 8 Oct 2011 20:05:10 +0000 (13:05 -0700)
If the stash in question has no name, the attempt to generate the
warning will cause a crash.

Simply skipping the warning is this case is fine, as this is will into
‘undefined’ territory (but it still shouldn’t crash).

op.c
t/op/stash.t

diff --git a/op.c b/op.c
index f9a1262..939b478 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6937,14 +6937,14 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
             }
             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
                 /* already defined (or promised) */
-                /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
                 if (ckWARN(WARN_REDEFINE)) {
                     GV * const gvcv = CvGV(cv);
                     if (gvcv) {
                         HV * const stash = GvSTASH(gvcv);
                         if (stash) {
                             const char *redefined_name = HvNAME_get(stash);
-                            if ( strEQ(redefined_name,"autouse") ) {
+                            if ( redefined_name &&
+                                 strEQ(redefined_name,"autouse") ) {
                                 const line_t oldline = CopLINE(PL_curcop);
                                 if (PL_parser && PL_parser->copline != NOLINE)
                                     CopLINE_set(PL_curcop, PL_parser->copline);
index 8132e9d..d755f74 100644 (file)
@@ -7,7 +7,7 @@ BEGIN {
 
 BEGIN { require "./test.pl"; }
 
-plan( tests => 55 );
+plan( tests => 56 );
 
 # Used to segfault (bug #15479)
 fresh_perl_like(
@@ -25,6 +25,17 @@ fresh_perl_is(
     q(Insert a non-GV in a stash, under warnings 'once'),
 );
 
+# Used to segfault, too
+SKIP: {
+ skip_if_miniperl('requires XS');
+  fresh_perl_is(
+    'sub foo::bar{}; $mro::{get_mro}=*foo::bar; undef %foo::; require mro',
+    '',
+    { switches => [ '-w' ] },
+    q(Defining an XSUB over an existing sub with no stash under warnings),
+  );
+}
+
 {
     no warnings 'deprecated';
     ok( defined %oedipa::maas::, q(stashes happen to be defined if not used) );