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.

6 files changed, 117 insertions, 29 deletions

diff --git a/gv.c b/gv.c
index 7741af36c9..d22a4398fb 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 ed5061fb6d..56598d79fb 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 115da8b97f..30be935157 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 69cdfa9b55..f330e5efda 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 3fa3d6cbaf..b08e8edd2f 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 db79dcde70..dcef480398 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 }