Skip to content

Commit

Permalink
Followup to 088225f/[perl #88132]: packages ending with :
Browse files Browse the repository at this point in the history 
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.
  • Loading branch information
Father Chrysostomos committed Apr 16, 2011
1 parent 2f81e8f commit 1f656fc
Show file tree
Hide file tree
Showing 6 changed files with 117 additions and 29 deletions.
10 changes: 9 additions & 1 deletion gv.c
View file
Expand Up @@ -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;
}
Expand Down
9 changes: 7 additions & 2 deletions hv.c
View file
Expand Up @@ -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)) {
Expand Down Expand Up @@ -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
Expand Down
61 changes: 43 additions & 18 deletions mro.c
View file
Expand Up @@ -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;
Expand All @@ -752,27 +752,36 @@ 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 {
SV *aname;
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);
}
Expand Down Expand Up @@ -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;
Expand All @@ -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,
Expand Down Expand Up @@ -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
Expand All @@ -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,
Expand Down
11 changes: 8 additions & 3 deletions sv.c
View file
Expand Up @@ -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
Expand Down Expand Up @@ -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(
Expand Down Expand Up @@ -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))) {
Expand Down
50 changes: 46 additions & 4 deletions t/mro/package_aliases.t
View file
Expand Up @@ -10,7 +10,7 @@ BEGIN {

use strict;
use warnings;
plan(tests => 39);
plan(tests => 52);

{
package New;
Expand Down Expand Up @@ -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__;
Expand All @@ -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");
Expand Down Expand Up @@ -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';
}


5 changes: 4 additions & 1 deletion t/op/universal.t
View file
Expand Up @@ -10,7 +10,7 @@ BEGIN {
require "./test.pl";
}

plan tests => 124;
plan tests => 125;

$a = {};
bless $a, "Bob";
Expand Down Expand Up @@ -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 }
Expand Down

0 comments on commit 1f656fc

Please sign in to comment.