From 1f656fcf060e343780f7a91a2ce567e8a9de9414 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Fri, 15 Apr 2011 22:33:31 -0700 Subject: [PATCH] Followup to 088225f/[perl #88132]: packages ending with : Commit 088225f was not sufficient to fix the regression. It still exists for packages whose names end with a single colon. I discovered this when trying to determine why RDF::Trine was crashing with 5.14-to-be. In trying to write tests for it, I ended up triggering the same crash that RDF::Trine is having, but in a different way. In the end, it was easier to fix about three or four bugs (depending on how you count them), rather than try to fix only the regression that #88132 deals with (isa caches not updating when packages ending with colons are aliased), as they are all intertwined. The changes are as follows: Concerning the if (!(flags & ~GV_NOADD_MASK)...) statement in gv_stashpvn: Normally, gv_fetchpvn_flags (which it calls and whose retval is assigned to tmpgv) returns NULL if it has not been told to add anything and if the gv requested looks like a stash gv (ends with ::). If the number of colons is odd (foo:::), that code path is bypassed, so gv_stashpvn returns a GV without a hash. So gv_stashpvn tries to used that NULL hash and crashes. It should instead return NULL, to be consistent with the two-colon case. Blindly assigning a name to a stash does not work if the stash has multiple effective names. A call to mro_package_moved is required as well. So what gv_stashpvn was doing was insufficient. The parts of the mro code that check for globs or stash elems that contain stashes by looking for :: at the end of the name now take into account that the name might consist of a single : instead. --- gv.c | 10 +++++++- hv.c | 9 ++++++-- mro.c | 61 ++++++++++++++++++++++++++++++++++--------------- sv.c | 11 ++++++--- t/mro/package_aliases.t | 50 ++++++++++++++++++++++++++++++++++++---- t/op/universal.t | 5 +++- 6 files changed, 117 insertions(+), 29 deletions(-) diff --git a/gv.c b/gv.c index 7741af3..d22a439 100644 --- a/gv.c +++ b/gv.c @@ -959,8 +959,16 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) if (!tmpgv) return NULL; stash = GvHV(tmpgv); - if (!HvNAME_get(stash)) + if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; + if (!HvNAME_get(stash)) { hv_name_set(stash, name, namelen, 0); + + /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ + /* If the containing stash has multiple effective + names, see that this one gets them, too. */ + if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) + mro_package_moved(stash, NULL, tmpgv, 1); + } assert(stash); return stash; } diff --git a/hv.c b/hv.c index ed5061f..56598d7 100644 --- a/hv.c +++ b/hv.c @@ -1026,7 +1026,11 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, if (HeVAL(entry) && HvENAME_get(hv)) { gv = (GV *)HeVAL(entry); if (keysv) key = SvPV(keysv, klen); - if (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':' + if (( + (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':') + || + (klen == 1 && key[0] == ':') + ) && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6)) && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv)) && HvENAME_get(stash)) { @@ -1780,7 +1784,8 @@ S_hfreeentries(pTHX_ HV *hv) ) { STRLEN klen; const char * const key = HePV(oentry,klen); - if (klen > 1 && key[klen-1]==':' && key[klen-2]==':') { + if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':') + || (klen == 1 && key[0] == ':')) { mro_package_moved( NULL, GvHV(HeVAL(oentry)), (GV *)HeVAL(oentry), 0 diff --git a/mro.c b/mro.c index 115da8b..30be935 100644 --- a/mro.c +++ b/mro.c @@ -738,9 +738,9 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, ) return; } assert(SvOOK(GvSTASH(gv))); - assert(GvNAMELEN(gv) > 1); + assert(GvNAMELEN(gv)); assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':'); - assert(GvNAME(gv)[GvNAMELEN(gv) - 2] == ':'); + assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':'); name_count = HvAUX(GvSTASH(gv))->xhv_name_count; if (!name_count) { name_count = 1; @@ -752,13 +752,17 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, } if (name_count == 1) { if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) { - namesv = newSVpvs_flags("", SVs_TEMP); + namesv = GvNAMELEN(gv) == 1 + ? newSVpvs_flags(":", SVs_TEMP) + : newSVpvs_flags("", SVs_TEMP); } else { namesv = sv_2mortal(newSVhek(*namep)); - sv_catpvs(namesv, "::"); + if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":"); + else sv_catpvs(namesv, "::"); } - sv_catpvn(namesv, GvNAME(gv), GvNAMELEN(gv) - 2); + if (GvNAMELEN(gv) != 1) + sv_catpvn(namesv, GvNAME(gv), GvNAMELEN(gv) - 2); /* skip trailing :: */ } else { @@ -766,13 +770,18 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, namesv = sv_2mortal((SV *)newAV()); while (name_count--) { if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){ - aname = newSVpvs(""); namep++; + aname = GvNAMELEN(gv) == 1 + ? newSVpvs(":") + : newSVpvs(""); + namep++; } else { aname = newSVhek(*namep++); - sv_catpvs(aname, "::"); + if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":"); + else sv_catpvs(aname, "::"); } - sv_catpvn(aname, GvNAME(gv), GvNAMELEN(gv) - 2); + if (GvNAMELEN(gv) != 1) + sv_catpvn(aname, GvNAME(gv), GvNAMELEN(gv) - 2); /* skip trailing :: */ av_push((AV *)namesv, aname); } @@ -1069,7 +1078,8 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, if (!isGV(HeVAL(entry))) continue; key = hv_iterkey(entry, &len); - if(len > 1 && key[len-2] == ':' && key[len-1] == ':') { + if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') + || (len == 1 && key[0] == ':')) { HV * const oldsubstash = GvHV(HeVAL(entry)); SV ** const stashentry = stash ? hv_fetch(stash, key, len, 0) : NULL; @@ -1096,15 +1106,22 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, subname = sv_2mortal((SV *)newAV()); while (items--) { aname = newSVsv(*svp++); - sv_catpvs(aname, "::"); - sv_catpvn(aname, key, len-2); + if (len == 1) + sv_catpvs(aname, ":"); + else { + sv_catpvs(aname, "::"); + sv_catpvn(aname, key, len-2); + } av_push((AV *)subname, aname); } } else { subname = sv_2mortal(newSVsv(namesv)); - sv_catpvs(subname, "::"); - sv_catpvn(subname, key, len-2); + if (len == 1) sv_catpvs(subname, ":"); + else { + sv_catpvs(subname, "::"); + sv_catpvn(subname, key, len-2); + } } mro_gather_and_rename( stashes, seen_stashes, @@ -1138,7 +1155,8 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, if (!isGV(HeVAL(entry))) continue; key = hv_iterkey(entry, &len); - if(len > 1 && key[len-2] == ':' && key[len-1] == ':') { + if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') + || (len == 1 && key[0] == ':')) { HV *substash; /* If this entry was seen when we iterated through the @@ -1164,15 +1182,22 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, subname = sv_2mortal((SV *)newAV()); while (items--) { aname = newSVsv(*svp++); - sv_catpvs(aname, "::"); - sv_catpvn(aname, key, len-2); + if (len == 1) + sv_catpvs(aname, ":"); + else { + sv_catpvs(aname, "::"); + sv_catpvn(aname, key, len-2); + } av_push((AV *)subname, aname); } } else { subname = sv_2mortal(newSVsv(namesv)); - sv_catpvs(subname, "::"); - sv_catpvn(subname, key, len-2); + if (len == 1) sv_catpvs(subname, ":"); + else { + sv_catpvs(subname, "::"); + sv_catpvn(subname, key, len-2); + } } mro_gather_and_rename( stashes, seen_stashes, diff --git a/sv.c b/sv.c index 69cdfa9..f330e5e 100644 --- a/sv.c +++ b/sv.c @@ -3719,7 +3719,8 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) mro_changes = 2; else { const STRLEN len = GvNAMELEN(dstr); - if (len > 1 && name[len-2] == ':' && name[len-1] == ':') { + if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') + || (len == 1 && name[0] == ':')) { mro_changes = 3; /* Set aside the old stash, so we can reset isa caches on @@ -3879,7 +3880,10 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) const char * const name = GvNAME((GV*)dstr); const STRLEN len = GvNAMELEN(dstr); if ( - len > 1 && name[len-2] == ':' && name[len-1] == ':' + ( + (len > 1 && name[len-2] == ':' && name[len-1] == ':') + || (len == 1 && name[0] == ':') + ) && (!dref || HvENAME_get(dref)) ) { mro_package_moved( @@ -4177,7 +4181,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) const STRLEN len = GvNAMELEN(dstr); HV *old_stash = NULL; bool reset_isa = FALSE; - if (len > 1 && name[len-2] == ':' && name[len-1] == ':') { + if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') + || (len == 1 && name[0] == ':')) { /* Set aside the old stash, so we can reset isa caches on its subclasses. */ if((old_stash = GvHV(dstr))) { diff --git a/t/mro/package_aliases.t b/t/mro/package_aliases.t index 3fa3d6c..b08e8ed 100644 --- a/t/mro/package_aliases.t +++ b/t/mro/package_aliases.t @@ -10,7 +10,7 @@ BEGIN { use strict; use warnings; -plan(tests => 39); +plan(tests => 52); { package New; @@ -154,13 +154,13 @@ for( code => '*clone:: = \%outer::', }, ) { - for my $tail ('inner', 'inner::', 'inner::::') { + for my $tail ('inner', 'inner::', 'inner:::', 'inner::::') { fresh_perl_is q~ my $tail = shift; @left::ISA = "outer::$tail"; @right::ISA = "clone::$tail"; - eval "package outer::$tail"; + bless [], "outer::$tail"; # autovivify the stash __code__; @@ -183,7 +183,7 @@ for( __code__; - eval qq{package outer::$tail}; + bless [], "outer::$tail"; print "ok 1", "\n" if left->isa("clone::$tail"); print "ok 2", "\n" if right->isa("outer::$tail"); @@ -358,3 +358,45 @@ is eval { 'Subclass'->womp }, 'clumpren', is frump brumkin, "good bye", 'detached stashes lose all names corresponding to the containing stash'; } + +# Crazy edge cases involving packages ending with a single : +@Colon::ISA = 'Organ:'; # pun intended! +bless [], "Organ:"; # autovivify the stash +ok "Colon"->isa("Organ:"), 'class isa "class:"'; +{ no strict 'refs'; *{"Organ:::"} = *Organ:: } +ok "Colon"->isa("Organ"), + 'isa(foo) when inheriting from "class:" which is an alias for foo'; +{ + no warnings; + # The next line of code is *not* normative. If the structure changes, + # this line needs to change, too. + my $foo = delete $Organ::{":"}; + ok !Colon->isa("Organ"), + 'class that isa "class:" no longer isa foo if "class:" has been deleted'; +} +@Colon::ISA = ':'; +bless [], ":"; +ok "Colon"->isa(":"), 'class isa ":"'; +{ no strict 'refs'; *{":::"} = *Punctuation:: } +ok "Colon"->isa("Punctuation"), + 'isa(foo) when inheriting from ":" which is an alias for foo'; +@Colon::ISA = 'Organ:'; +bless [], "Organ:"; +{ + no strict 'refs'; + my $life_raft = \%{"Organ:::"}; + *{"Organ:::"} = \%Organ::; + ok "Colon"->isa("Organ"), + 'isa(foo) when inheriting from "class:" after hash-to-glob assignment'; +} +@Colon::ISA = 'O:'; +bless [], "O:"; +{ + no strict 'refs'; + my $life_raft = \%{"O:::"}; + *{"O:::"} = "Organ::"; + ok "Colon"->isa("Organ"), + 'isa(foo) when inheriting from "class:" after string-to-glob assignment'; +} + + diff --git a/t/op/universal.t b/t/op/universal.t index db79dcd..dcef480 100644 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -10,7 +10,7 @@ BEGIN { require "./test.pl"; } -plan tests => 124; +plan tests => 125; $a = {}; bless $a, "Bob"; @@ -200,6 +200,9 @@ is $@, ''; # This segfaulted in a blead. fresh_perl_is('package Foo; Foo->VERSION; print "ok"', 'ok'); +# So did this. +fresh_perl_is('$:; UNIVERSAL::isa(":","Unicode::String");print "ok"','ok'); + package Foo; sub DOES { 1 } -- 2.7.4