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.

diff --git a/embed.fnc b/embed.fnc
index 37263dd..780c4f9 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1777,6 +1777,13 @@ sR       |I32    |do_trans_complex_utf8  |NN SV * const sv
 #if defined(PERL_IN_GV_C)
 s      |void   |gv_init_svtype |NN GV *gv|const svtype sv_type
 s      |void   |gv_magicalize_isa      |NN GV *gv
+s  |bool|parse_gv_stash_name|NN HV **stash|NN GV **gv \
+                     |NN const char **name|NN STRLEN *len \
+                     |NN const char *nambeg|STRLEN full_len \
+                     |const U32 is_utf8|const I32 add
+s  |bool|find_default_stash|NN HV **stash|NN const char *name \
+                     |STRLEN len|const U32 is_utf8|const I32 add \
+                     |svtype sv_type
 s      |HV*    |require_tie_mod|NN GV *gv|NN const char *varpv|NN SV* namesv \
                                |NN const char *methpv|const U32 flags
 #endif

diff --git a/embed.h b/embed.h
index 7e0f83e..ddd6645 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1378,8 +1378,10 @@
 #define sequence_num(a)                S_sequence_num(aTHX_ a)
 #  endif
 #  if defined(PERL_IN_GV_C)
+#define find_default_stash(a,b,c,d,e,f)        S_find_default_stash(aTHX_ a,b,c,d,e,f)
 #define gv_init_svtype(a,b)    S_gv_init_svtype(aTHX_ a,b)
 #define gv_magicalize_isa(a)   S_gv_magicalize_isa(aTHX_ a)
+#define parse_gv_stash_name(a,b,c,d,e,f,g,h)   S_parse_gv_stash_name(aTHX_ a,b,c,d,e,f,g,h)
 #define require_tie_mod(a,b,c,d,e)     S_require_tie_mod(aTHX_ a,b,c,d,e)
 #  endif
 #  if defined(PERL_IN_HV_C)

diff --git a/gv.c b/gv.c
index 5456b25..94e6474 100644 (file)
--- 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);

diff --git a/proto.h b/proto.h
index c37abcf..e77c66d 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5718,6 +5718,12 @@ PERL_CALLCONV void       Perl_hv_kill_backrefs(pTHX_ HV *hv)
 
 #endif
 #if defined(PERL_IN_GV_C)
+STATIC bool    S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, const U32 is_utf8, const I32 add, svtype sv_type)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_FIND_DEFAULT_STASH    \
+       assert(stash); assert(name)
+
 STATIC void    S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_GV_INIT_SVTYPE        \
@@ -5728,6 +5734,15 @@ STATIC void      S_gv_magicalize_isa(pTHX_ GV *gv)
 #define PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA     \
        assert(gv)
 
+STATIC 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)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2)
+                       __attribute__nonnull__(pTHX_3)
+                       __attribute__nonnull__(pTHX_4)
+                       __attribute__nonnull__(pTHX_5);
+#define PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME   \
+       assert(stash); assert(gv); assert(name); assert(len); assert(nambeg)
+
 STATIC HV*     S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv, const U32 flags)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2)