Skip to content

Commit

Permalink
C 1.52_09: fix SvSTASH crash for unpatched perls
Browse files Browse the repository at this point in the history 
Provide our own B::HV::SvSTASH method and check against an invalid
STASH ptr (< arenaroot). Note that make_sv_object already mortalizes.
Apply the patch from [perl #126410] for my_curse. See GH #219

5.18 AMG has no SvSTASH
  • Loading branch information
Reini Urban committed Oct 28, 2015
1 parent 77f8dd1 commit d8296b2
Show file tree
Hide file tree
Showing 3 changed files with 73 additions and 29 deletions.
14 changes: 14 additions & 0 deletions C.xs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -243,6 +243,20 @@ PPCODE:

#endif

MODULE = B PACKAGE = B::HV

#if PERL_VERSION > 17

SV*
SvSTASH(hv)
B::HV hv
PPCODE:
HV* stash = SvSTASH(MUTABLE_SV(hv)); /* [perl #126410] */
ST(0) = (char*)stash < (char*)PL_sv_arenaroot
? &PL_sv_undef : make_sv_object(aTHX_ MUTABLE_SV(stash));

#endif

MODULE = B PACKAGE = B::UNOP_AUX

#if PERL_VERSION > 21
Expand Down
85 changes: 57 additions & 28 deletions lib/B/C.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,7 @@
package B::C;
use strict;

our $VERSION = '1.52_08';
our $VERSION = '1.52_09';
our %debug;
our $check;
my $eval_pvs = '';
Expand Down Expand Up @@ -302,6 +302,7 @@ BEGIN {
SVf_FAKE)); # both unsupported for 5.6
eval q[
sub SVs_OBJECT() {0x00100000}
sub SVf_AMAGIC() {0x10000000}
];
} else {
eval q[
Expand All @@ -311,6 +312,7 @@ BEGIN {
sub PMf_ONCE() {0xff}; # unused
sub SVf_FAKE() {0x00100000}; # unused
sub SVs_OBJECT() {0x00001000}
sub SVf_AMAGIC() {0x10000000}
];
@B::PVMG::ISA = qw(B::PVNV B::RV);
}
Expand Down Expand Up @@ -490,7 +492,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 );
Expand Down Expand Up @@ -786,6 +788,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;
}
Expand Down Expand Up @@ -1492,7 +1496,7 @@ sub B::UNOP_AUX::save {
$unopauxsect->debug( $op->name, $op->flagspv ) if $debug{flags};
# This cannot be a section, as the number of elements is variable
my $i = 1;
my $s = "Static UNOP_AUX_item unopaux_item${ix}[] = {\n\t"
my $s = "Static UNOP_AUX_item unopaux_item".$ix."[] = {\n\t"
.($C99?"{.uv=$auxlen}":$auxlen). " \t/* length prefix */\n";
my $action = 0;
for my $item (@aux_list) {
Expand Down Expand Up @@ -1532,7 +1536,7 @@ sub B::UNOP_AUX::save {
# || SvROK(keysv)
# || SvIsCOW_shared_hash(keysv));
my $constkey = ($action & 0x30) == 0x10 ? 1 : 0;
my $itemsym = $item->save("unopaux_item${ix}[$i]" . ($constkey ? " const" : ""));
my $itemsym = $item->save("unopaux_item".$ix."[$i]" . ($constkey ? " const" : ""));
if (is_constant($itemsym)) {
if (ref $item eq 'B::IV') {
my $iv = $item->IVX;
Expand All @@ -1550,7 +1554,7 @@ sub B::UNOP_AUX::save {
# gv or other late inits
$s .= ($C99 ? "\t,{.sv=Nullsv} \t/* $itemsym */\n"
: "\t,0 \t/* $itemsym */\n");
$init2->add("unopaux_item${ix}[$i].sv = (SV*)$itemsym;");
$init2->add("unopaux_item".$ix."[$i].sv = (SV*)$itemsym;");
}
}
$i++;
Expand Down Expand Up @@ -3147,43 +3151,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 $fullname (0x%x) flags=0x%x%s - called from %s:%s\n",
class($sv), $$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
# 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 (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)
if $verbose;
} else {
# 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;
# 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) {
warn sprintf("stash isa class(\"%s\") 0x%x\n", $pkg->NAME, $$pkg)
if ($pkg and $$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
#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));
}
}
# Protect our SVs against non-magic or SvPAD_OUR. Fixes tests 16 and 14 + 23
Expand Down Expand Up @@ -5955,21 +5982,23 @@ my_curse( pTHX_ SV* const sv ) {
assert(SvTYPE(stash) == SVt_PVHV);
if (HvNAME(stash)) {
CV* destructor = NULL;
assert (SvOOK(stash));
if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
if (!destructor
#if (PERL_VERSION > 18) || (PERL_VERSION == 18 && PERL_SUBVERSION > 1)
|| HvMROMETA(stash)->destroy_gen != PL_sub_generation
#endif
) {
GV * const gv = gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
if (gv) destructor = GvCV(gv);
if (!SvOBJECT(stash))
{
SvSTASH(stash) =
destructor ? (HV *)destructor : ((HV *)0)+1;
if (gv) {
destructor = GvCV(gv);
if (!SvOBJECT(stash)) {
SvSTASH(stash) =
destructor ? (HV *)destructor : ((HV *)0)+1;
#if (PERL_VERSION > 18) || (PERL_VERSION == 18 && PERL_SUBVERSION > 1)
HvAUX(stash)->xhv_mro_meta->destroy_gen = PL_sub_generation;
HvAUX(stash)->xhv_mro_meta->destroy_gen = PL_sub_generation;
#endif
}
}
}
assert(!destructor || destructor == ((CV *)0)+1
Expand Down
3 changes: 2 additions & 1 deletion t/testc.sh
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1345,7 +1345,8 @@ do
done

if [ "$(perl -V:gccversion)" != "gccversion='';" ]; then
if [ "$(uname)" = "Darwin" ]; then
if [ "$(uname)" = "xxDarwin" ]; then
# I guess gcc-mp-4.8 or applce clang was broken. gcc-mp-5.2.0 works ok now
CCMD="$CCMD -g -fno-var-tracking"
else
CCMD="$CCMD -g3"
Expand Down

0 comments on commit d8296b2

Please sign in to comment.