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.

diff --git a/gv.c b/gv.c
index 7741af3..d22a439 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 }