C 1.52_09: fix SvSTASH crash for unpatched perls

Apply the patch from [perl #126410] for my_curse. See GH rurban#219 5.18 AMG has no SvSTASH It still crashed with %version. Provide our own B::HV::SvSTASH method and check against an invalid STASH ptr (< arenaroot).
cpanel · Nov 10, 2015 · 5ea8307 · 5ea8307
1 parent 1359b18
commit 5ea8307
Show file tree

Hide file tree

Showing 2 changed files with 42 additions and 21 deletions.
diff --git a/C.xs b/C.xs
@@ -248,7 +248,7 @@ MODULE = B      PACKAGE = B::HV
 #if PERL_VERSION > 17
 
 SV*
-SvSTASH_not(hv)
+SvSTASH(hv)
           B::HV hv
 PPCODE:
     HV* stash = SvSTASH(MUTABLE_SV(hv)); /* [perl #126410] */

diff --git a/lib/B/C.pm b/lib/B/C.pm
@@ -503,7 +503,7 @@ my $MULTI = $Config{usemultiplicity};
 my $ITHREADS = $Config{useithreads};
 my $DEBUGGING = ($Config{ccflags} =~ m/-DDEBUGGING/);
 my $DEBUG_LEAKING_SCALARS = $Config{ccflags} =~ m/-DDEBUG_LEAKING_SCALARS/;
-my $CPERL52  = ( $Config{usecperl} and $] >= 5.022002 ); #sv_objcount
+my $CPERL52  = ( $Config{usecperl} and $] >= 5.022002 ); #sv_objcount, SvSTASH crash
 my $CPERL51  = ( $Config{usecperl} );
 my $PERL522  = ( $] >= 5.021006 ); #PADNAMELIST, IsCOW, padname_with_str
 my $PERL518  = ( $] >= 5.017010 );
@@ -800,6 +800,8 @@ sub savestash_flags {
   $decl->add("Static HV *hv$hv_index;");
   my $pvok = $pv eq '0' || !$len ? q{""} : $pv;
   $init->add( sprintf( "%s = gv_stashpvn(%s, %u, %s);", $sym, $pvok, $len, $flags));
+  # sv_bless does not call it anymore
+  # $init2->add(sprintf("Gv_AMG(%s); /* XXX overload-219 for $pv */", $sym)) if $PERL518;
   $hv_index++;
   return $stashtable{$pv} = $sym;
 }
@@ -3279,47 +3281,66 @@ sub B::PVMG::save_magic {
     my $flagspv = "";
     $fullname = '' unless $fullname;
     $flagspv = $sv->flagspv if $debug{flags} and $PERL510 and !$sv->MAGICAL;
-    warn sprintf( "saving magic for %s %s (0x%x) flags=0x%x%s  - called from %s:%s\n",
-		class($sv), $fullname, $$sv, $sv_flags, $debug{flags} ? "(".$flagspv.")" : "",
-		@{[(caller(1))[3]]}, @{[(caller(1))[2]]});
+    warn sprintf( "saving magic for %s %s (0x%x) flags=0x%x%s\n",
+                  class($sv), $fullname, $$sv, $sv_flags,
+                  $debug{flags} ? " (".$flagspv.")" : "");
   }
 
   # crashes on STASH=0x18 with HV PERL_MAGIC_overload_table stash %version:: flags=0x3280000c
-  # needs core patch 
-  # issue267 GetOpt::Long SVf_AMAGIC|SVs_RMG|SVf_OOK
+  # also issue267 GetOpt::Long SVf_AMAGIC|SVs_RMG|SVf_OOK
   # crashes with %Class::MOP::Instance:: flags=0x2280000c also
-  if (0 and ref($sv) eq 'B::HV' and $] > 5.018 and $sv->MAGICAL and $fullname =~ /::$/) {
-    warn sprintf("skip SvSTASH for overloaded HV %s flags=0x%x\n", $fullname, $sv->FLAGS)
-      if $verbose;
-  # [cperl #60] not only overloaded, version also
-  #} elsif (ref($sv) eq 'B::HV' and $] > 5.018 and $fullname =~ /(version|File)::$/) {
-  #  warn sprintf("skip SvSTASH for %s flags=0x%x\n", $fullname, $sv->FLAGS)
+  # fixed with [perl #126410] patch in my_curse
+  # HV->SvSTASH crashed on %version and %File, so we had to patch it in C.xs
+  #if ($PERL518 and ref($sv) eq 'B::HV' and $sv_flags & SVf_AMAGIC and $fullname =~ /::$/) {
+  #  warn sprintf("skip SvSTASH for HV %s flags=0x%x\n", $fullname, $sv->FLAGS)
   #    if $verbose;
-  } else {
-    $pkg = $sv->SvSTASH;
+  #  if ($PERL518 and ref($sv) eq 'B::HV' and $sv_flags & SVf_AMAGIC
+  #      and $fullname =~ /::$/)
+  #  {
+  #    my $name = $fullname;
+  #    $name =~ s/^%(.*)::$/$1/;
+  #    warn sprintf("initialize overload cache for %s (no SvSTASH)\n", $fullname )
+  #      if $debug{mg} or $debug{gv};
+  #    $init2->add(sprintf("Gv_AMG(%s); /* init AMG overload for %s */", savestashpv($name),
+  #                        $fullname));
+  #  }
+  #} else
+  {
+    my $pkg = $sv->SvSTASH;
     if ($pkg and $$pkg) {
-      warn sprintf("stash isa class(\"%s\") 0x%x\n", $pkg->NAME, $$pkg)
+      my $name = $pkg->NAME;
+      warn sprintf("stash isa class(\"%s\") 0x%x\n", $name, $$pkg)
         if $debug{mg} or $debug{gv};
       # 361 do not force dynaloading IO via IO::Handle upon us
       # core already initialized this stash for us
       unless ($fullname eq 'main::STDOUT' and $] >= 5.018) {
         $pkg->save($fullname);
 
         no strict 'refs';
-        warn sprintf( "xmg_stash = \"%s\" (0x%x)\n", $pkg->NAME, $$pkg )
+        warn sprintf( "xmg_stash = \"%s\" (0x%x)\n", $name, $$pkg )
           if $debug{mg} or $debug{gv};
         # Q: Who is initializing our stash from XS? ->save is missing that.
         # A: We only need to init it when we need a CV
         # defer for XS loaded stashes with AMT magic
         $init->add( sprintf( "SvSTASH_set(s\\_%x, (HV*)s\\_%x);", $$sv, $$pkg ) );
         $init->add( sprintf( "SvREFCNT((SV*)s\\_%x) += 1;", $$pkg ) );
         $init->add("++PL_sv_objcount;") unless ref($sv) eq "B::IO";
-        # XXX 219?
-        if ($sv->MAGICAL and $PERL518) {
-          warn sprintf( "mark magical %s\n", $pkg->NAME ) if $verbose and $PERL518;
-          push_package($pkg->NAME);  # correct code, but adds lots of new stashes
+        if ($PERL518 and $sv->MAGICAL) {
+          warn sprintf("initialize AMG for %s\n", $name )
+            if $debug{mg} or $debug{gv};
+          $init2->add(sprintf("Gv_AMG(%s); /* init AMG for %s */",
+                              $$pkg, $name));
+          warn sprintf( "mark magical %s\n", $name ) if $verbose and $PERL518;
+          push_package($name);  # correct code, but adds lots of new stashes
         }
       }
+    } else {
+      my $name = $fullname;
+      $name =~ s/^%(.*)::$/$1/;
+      warn sprintf("initialize overload cache for %s (no SvSTASH)\n", $fullname )
+        if $debug{mg} or $debug{gv};
+      $init2->add(sprintf("Gv_AMG(%s); /* init AMG overload for %s */", savestashpv($name),
+                          $fullname));
     }
   }
   $init->add(sprintf("SvREADONLY_off((SV*)s\\_%x);", $$sv))