gv.c: Begin splitting gv_fetchpvn_flags into smaller helper functions.

This commit takes a chunk of code out of gv_fetchpvn_flags and
turns it into two fuctions: parse_gv_stash_name and find_default_stash.

1 files changed, 246 insertions, 195 deletions

diff --git a/gv.c b/gv.c
index 5456b25b5b..94e6474f48 100644
--- a/gv.c
+++ b/gv.c
@@ -1387,7 +1387,7 @@ Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
 }
 
-STATIC void
+PERL_STATIC_INLINE void
 S_gv_magicalize_isa(pTHX_ GV *gv)
 {
     AV* av;
@@ -1400,6 +1400,237 @@ S_gv_magicalize_isa(pTHX_ GV *gv)
 	     NULL, 0);
 }
 
+/* This function grabs name and tries to split a stash and glob
+ * from its contents. TODO better description, comments
+ * 
+ * If the function returns TRUE and 'name == name_end', then
+ * 'gv' can be directly returned to the caller of gv_fetchpvn_flags
+ */
+PERL_STATIC_INLINE bool
+S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name,
+               STRLEN *len, const char *nambeg, STRLEN full_len,
+               const U32 is_utf8, const I32 add)
+{
+    const char *name_cursor;
+    const char *const name_end = nambeg + full_len;
+    const char *const name_em1 = name_end - 1;
+
+    PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME;
+    
+    if (full_len > 2 && **name == '*' && isIDFIRST_lazy_if(*name + 1, is_utf8)) {
+        /* accidental stringify on a GV? */
+        (*name)++;
+    }
+
+    for (name_cursor = *name; name_cursor < name_end; name_cursor++) {
+        if (name_cursor < name_em1 &&
+            ((*name_cursor == ':' && name_cursor[1] == ':')
+           || *name_cursor == '\''))
+        {
+            if (!*stash)
+                *stash = PL_defstash;
+            if (!*stash || !SvREFCNT(*stash)) /* symbol table under destruction */
+                return FALSE;
+
+            *len = name_cursor - *name;
+            if (name_cursor > nambeg) { /* Skip for initial :: or ' */
+                const char *key;
+                GV**gvp;
+                if (*name_cursor == ':') {
+                    key = *name;
+                    *len += 2;
+                }
+                else {
+                    char *tmpbuf;
+                    Newx(tmpbuf, *len+2, char);
+                    Copy(*name, tmpbuf, *len, char);
+                    tmpbuf[(*len)++] = ':';
+                    tmpbuf[(*len)++] = ':';
+                    key = tmpbuf;
+                }
+                gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -(*len) : *len, add);
+                *gv = gvp ? *gvp : NULL;
+                if (*gv && *gv != (const GV *)&PL_sv_undef) {
+                    if (SvTYPE(*gv) != SVt_PVGV)
+                        gv_init_pvn(*gv, *stash, key, *len, (add & GV_ADDMULTI)|is_utf8);
+                    else
+                        GvMULTI_on(*gv);
+                }
+                if (key != *name)
+                    Safefree(key);
+                if (!*gv || *gv == (const GV *)&PL_sv_undef)
+                    return FALSE;
+
+                if (!(*stash = GvHV(*gv))) {
+                    *stash = GvHV(*gv) = newHV();
+                    if (!HvNAME_get(*stash)) {
+                        if (GvSTASH(*gv) == PL_defstash && *len == 6
+                            && strnEQ(*name, "CORE", 4))
+                            hv_name_set(*stash, "CORE", 4, 0);
+                        else
+                            hv_name_set(
+                                *stash, nambeg, name_cursor-nambeg, is_utf8
+                            );
+                    /* If the containing stash has multiple effective
+                    names, see that this one gets them, too. */
+                    if (HvAUX(GvSTASH(*gv))->xhv_name_count)
+                        mro_package_moved(*stash, NULL, *gv, 1);
+                    }
+                }
+                else if (!HvNAME_get(*stash))
+                    hv_name_set(*stash, nambeg, name_cursor - nambeg, is_utf8);
+            }
+
+            if (*name_cursor == ':')
+                name_cursor++;
+            *name = name_cursor+1;
+            if (*name == name_end) {
+                if (!*gv)
+                    *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
+                return TRUE;
+            }
+        }
+    }
+    *len = name_cursor - *name;
+    return TRUE;
+}
+
+/* This function is called if parse_gv_stash_name() failed to
+ * find a stash, or if GV_NOTQUAL or an empty name was passed
+ * to gv_fetchpvn_flags.
+ * 
+ * It returns FALSE if the default stash can't be found nor created,
+ * which might happen during global destruction.
+ */
+PERL_STATIC_INLINE bool
+S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
+               const U32 is_utf8, const I32 add,
+               const svtype sv_type)
+{
+    PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
+    
+    /* No stash in name, so see how we can default */
+
+    /* If it's an alphanumeric variable */
+    if (len && isIDFIRST_lazy_if(name, is_utf8)) {
+        bool global = FALSE;
+
+        /* Some "normal" variables are always in main::,
+         * like INC or STDOUT.
+         */
+        switch (len) {
+            case 1:
+            if (*name == '_')
+                global = TRUE;
+            break;
+            case 3:
+            if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
+                || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
+                || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
+                global = TRUE;
+            break;
+            case 4:
+            if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
+                && name[3] == 'V')
+                global = TRUE;
+            break;
+            case 5:
+            if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
+                && name[3] == 'I' && name[4] == 'N')
+                global = TRUE;
+            break;
+            case 6:
+            if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
+                &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
+                    ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
+                global = TRUE;
+            break;
+            case 7:
+            if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
+                && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
+                && name[6] == 'T')
+                global = TRUE;
+            break;
+        }
+
+        if (global)
+            *stash = PL_defstash;
+        else if (IN_PERL_COMPILETIME) {
+            *stash = PL_curstash;
+            if (add && (PL_hints & HINT_STRICT_VARS) &&
+                sv_type != SVt_PVCV &&
+                sv_type != SVt_PVGV &&
+                sv_type != SVt_PVFM &&
+                sv_type != SVt_PVIO &&
+                !(len == 1 && sv_type == SVt_PV &&
+                (*name == 'a' || *name == 'b')) )
+            {
+                GV**gvp = (GV**)hv_fetch(*stash,name,is_utf8 ? -len : len,0);
+                if (!gvp || *gvp == (const GV *)&PL_sv_undef ||
+                    SvTYPE(*gvp) != SVt_PVGV)
+                {
+                    *stash = NULL;
+                }
+                else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
+                         (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
+                         (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
+                {
+                    /* diag_listed_as: Variable "%s" is not imported%s */
+                    Perl_ck_warner_d(
+                        aTHX_ packWARN(WARN_MISC),
+                        "Variable \"%c%"UTF8f"\" is not imported",
+                        sv_type == SVt_PVAV ? '@' :
+                        sv_type == SVt_PVHV ? '%' : '$',
+                        UTF8fARG(is_utf8, len, name));
+                    if (GvCVu(*gvp))
+                        Perl_ck_warner_d(
+                            aTHX_ packWARN(WARN_MISC),
+                            "\t(Did you mean &%"UTF8f" instead?)\n",
+                            UTF8fARG(is_utf8, len, name)
+                        );
+                    *stash = NULL;
+                }
+            }
+        }
+        else {
+            /* Use the current op's stash */
+            *stash = CopSTASH(PL_curcop);
+        }
+    }
+    /* *{""}, or a special variable like $@ */
+    else
+        *stash = PL_defstash;
+
+    if (!*stash) {
+        if (add && !PL_in_clean_all) {
+            SV * const err = Perl_mess(aTHX_
+                 "Global symbol \"%s%"UTF8f
+                 "\" requires explicit package name",
+                 (sv_type == SVt_PV ? "$"
+                  : sv_type == SVt_PVAV ? "@"
+                  : sv_type == SVt_PVHV ? "%"
+                  : ""), UTF8fARG(is_utf8, len, name));
+            GV *gv;
+            if (is_utf8)
+                SvUTF8_on(err);
+            qerror(err);
+            gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
+            if (!gv) {
+                /* symbol table under destruction */
+                return FALSE;
+            }
+            *stash = GvHV(gv);
+        }
+        else
+            return FALSE;
+    }
+
+    if (!SvREFCNT(*stash))   /* symbol table under destruction */
+        return FALSE;
+
+    return TRUE;
+}
+
 GV *
 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 		       const svtype sv_type)
@@ -1409,7 +1640,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     GV *gv = NULL;
     GV**gvp;
     STRLEN len;
-    const char *name_cursor;
     HV *stash = NULL;
     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
     const I32 no_expand = flags & GV_NOEXPAND;
@@ -1417,210 +1647,31 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     const U32 is_utf8 = flags & SVf_UTF8;
     bool addmg = !!(flags & GV_ADDMG);
     const char *const name_end = nambeg + full_len;
-    const char *const name_em1 = name_end - 1;
     U32 faking_it;
     SSize_t paren;
 
     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
 
-    if (flags & GV_NOTQUAL) {
-	/* Caller promised that there is no stash, so we can skip the check. */
-	len = full_len;
-	goto no_stash;
+     /* If we have GV_NOTQUAL, the caller promised that
+      * there is no stash, so we can skip the check.
+      * Similarly if full_len is 0, since then we're
+      * dealing with something like *{""} or ""->foo()
+      */
+    if ((flags & GV_NOTQUAL) || !full_len) {
+        len = full_len;
     }
-
-    if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
-	/* accidental stringify on a GV? */
-	name++;
+    else if (parse_gv_stash_name(&stash, &gv, &name, &len, nambeg, full_len, is_utf8, add)) {
+        if (name == name_end) return gv;
     }
-
-    for (name_cursor = name; name_cursor < name_end; name_cursor++) {
-	if (name_cursor < name_em1 &&
-	    ((*name_cursor == ':'
-	     && name_cursor[1] == ':')
-	    || *name_cursor == '\''))
-	{
-	    if (!stash)
-		stash = PL_defstash;
-	    if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
-		return NULL;
-
-	    len = name_cursor - name;
-	    if (name_cursor > nambeg) { /* Skip for initial :: or ' */
-		const char *key;
-		if (*name_cursor == ':') {
-		    key = name;
-		    len += 2;
-		} else {
-		    char *tmpbuf;
-		    Newx(tmpbuf, len+2, char);
-		    Copy(name, tmpbuf, len, char);
-		    tmpbuf[len++] = ':';
-		    tmpbuf[len++] = ':';
-		    key = tmpbuf;
-		}
-		gvp = (GV**)hv_fetch(stash, key, is_utf8 ? -len : len, add);
-		gv = gvp ? *gvp : NULL;
-		if (gv && gv != (const GV *)&PL_sv_undef) {
-		    if (SvTYPE(gv) != SVt_PVGV)
-			gv_init_pvn(gv, stash, key, len, (add & GV_ADDMULTI)|is_utf8);
-		    else
-			GvMULTI_on(gv);
-		}
-		if (key != name)
-		    Safefree(key);
-		if (!gv || gv == (const GV *)&PL_sv_undef)
-		    return NULL;
-
-		if (!(stash = GvHV(gv)))
-		{
-		    stash = GvHV(gv) = newHV();
-		    if (!HvNAME_get(stash)) {
-			if (GvSTASH(gv) == PL_defstash && len == 6
-			 && strnEQ(name, "CORE", 4))
-			    hv_name_set(stash, "CORE", 4, 0);
-			else
-			    hv_name_set(
-				stash, nambeg, name_cursor-nambeg, is_utf8
-			    );
-			/* If the containing stash has multiple effective
-			   names, see that this one gets them, too. */
-			if (HvAUX(GvSTASH(gv))->xhv_name_count)
-			    mro_package_moved(stash, NULL, gv, 1);
-		    }
-		}
-		else if (!HvNAME_get(stash))
-		    hv_name_set(stash, nambeg, name_cursor - nambeg, is_utf8);
-	    }
-
-	    if (*name_cursor == ':')
-		name_cursor++;
-	    name = name_cursor+1;
-	    if (name == name_end)
-		return gv
-		    ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
-	}
+    else {
+        return NULL;
     }
-    len = name_cursor - name;
-
-    /* No stash in name, so see how we can default */
-
-    if (!stash) {
-    no_stash:
-	if (len && isIDFIRST_lazy_if(name, is_utf8)) {
-	    bool global = FALSE;
-
-	    switch (len) {
-	    case 1:
-		if (*name == '_')
-		    global = TRUE;
-		break;
-	    case 3:
-		if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
-		    || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
-		    || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
-		    global = TRUE;
-		break;
-	    case 4:
-		if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
-		    && name[3] == 'V')
-		    global = TRUE;
-		break;
-	    case 5:
-		if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
-		    && name[3] == 'I' && name[4] == 'N')
-		    global = TRUE;
-		break;
-	    case 6:
-		if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
-		    &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
-		       ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
-		    global = TRUE;
-		break;
-	    case 7:
-		if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
-		    && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
-		    && name[6] == 'T')
-		    global = TRUE;
-		break;
-	    }
 
-	    if (global)
-		stash = PL_defstash;
-	    else if (IN_PERL_COMPILETIME) {
-		stash = PL_curstash;
-		if (add && (PL_hints & HINT_STRICT_VARS) &&
-		    sv_type != SVt_PVCV &&
-		    sv_type != SVt_PVGV &&
-		    sv_type != SVt_PVFM &&
-		    sv_type != SVt_PVIO &&
-		    !(len == 1 && sv_type == SVt_PV &&
-		      (*name == 'a' || *name == 'b')) )
-		{
-		    gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,0);
-		    if (!gvp ||
-			*gvp == (const GV *)&PL_sv_undef ||
-			SvTYPE(*gvp) != SVt_PVGV)
-		    {
-			stash = NULL;
-		    }
-		    else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
-			     (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
-			     (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
-		    {
-			/* diag_listed_as: Variable "%s" is not imported%s */
-			Perl_ck_warner_d(
-			    aTHX_ packWARN(WARN_MISC),
-			    "Variable \"%c%"UTF8f"\" is not imported",
-			    sv_type == SVt_PVAV ? '@' :
-			    sv_type == SVt_PVHV ? '%' : '$',
-			    UTF8fARG(is_utf8, len, name));
-			if (GvCVu(*gvp))
-			    Perl_ck_warner_d(
-				aTHX_ packWARN(WARN_MISC),
-				"\t(Did you mean &%"UTF8f" instead?)\n",
-				UTF8fARG(is_utf8, len, name)
-			    );
-			stash = NULL;
-		    }
-		}
-	    }
-	    else
-		stash = CopSTASH(PL_curcop);
-	}
-	else
-	    stash = PL_defstash;
+    if (!stash && !find_default_stash(&stash, name, len, is_utf8, add, sv_type)) {
+        return NULL;
     }
-
+    
     /* By this point we should have a stash and a name */
-
-    if (!stash) {
-	if (add && !PL_in_clean_all) {
-	    SV * const err = Perl_mess(aTHX_
-		 "Global symbol \"%s%"UTF8f
-		 "\" requires explicit package name",
-		 (sv_type == SVt_PV ? "$"
-		  : sv_type == SVt_PVAV ? "@"
-		  : sv_type == SVt_PVHV ? "%"
-		  : ""), UTF8fARG(is_utf8, len, name));
-	    GV *gv;
-	    if (is_utf8)
-		SvUTF8_on(err);
-	    qerror(err);
-	    gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
-	    if(!gv) {
-		/* symbol table under destruction */
-		return NULL;
-	    }	
-	    stash = GvHV(gv);
-	}
-	else
-	    return NULL;
-    }
-
-    if (!SvREFCNT(stash))	/* symbol table under destruction */
-	return NULL;
-
     gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -len : len,add);
     if (!gvp || *gvp == (const GV *)&PL_sv_undef) {
 	if (addmg) gv = (GV *)newSV(0);