gv.c: Split part of find_default_stash into gv_is_in_main.

gv_is_in_main() checks if an unqualified identifier is in the main::
stash.

4 files changed, 47 insertions, 28 deletions

diff --git a/embed.fnc b/embed.fnc
index cb19a1755f..6ad48d39eb 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1788,6 +1788,8 @@ s  |bool|gv_magicalize|NN GV *gv|NN HV *stash|NN const char *name \
                      |STRLEN len|bool addmg \
                      |svtype sv_type
 s  |void|maybe_multimagic_gv|NN GV *gv|NN const char *name|const svtype sv_type
+s  |bool|gv_is_in_main|NN const char *name|STRLEN len \
+                      |const U32 is_utf8
 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 1c3481aeca..1d213b2fd4 100644
--- a/embed.h
+++ b/embed.h
@@ -1380,6 +1380,7 @@
 #  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_is_in_main(a,b,c)	S_gv_is_in_main(aTHX_ a,b,c)
 #define gv_magicalize(a,b,c,d,e,f)	S_gv_magicalize(aTHX_ a,b,c,d,e,f)
 #define gv_magicalize_isa(a)	S_gv_magicalize_isa(aTHX_ a)
 #define maybe_multimagic_gv(a,b,c)	S_maybe_multimagic_gv(aTHX_ a,b,c)
diff --git a/gv.c b/gv.c
index cec6534be6..fc4393eb78 100644
--- a/gv.c
+++ b/gv.c
@@ -1495,67 +1495,81 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **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.
- */
+/* Checks if an unqualified name is in the main stash */
 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)
+S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
 {
-    PERL_ARGS_ASSERT_FIND_DEFAULT_STASH;
+    PERL_ARGS_ASSERT_GV_IS_IN_MAIN;
     
-    /* 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;
-
+    if ( len && isIDFIRST_lazy_if(name, is_utf8) ) {
         /* Some "normal" variables are always in main::,
          * like INC or STDOUT.
          */
         switch (len) {
             case 1:
             if (*name == '_')
-                global = TRUE;
+                return 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;
+                return TRUE;
             break;
             case 4:
             if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
                 && name[3] == 'V')
-                global = TRUE;
+                return TRUE;
             break;
             case 5:
             if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
                 && name[3] == 'I' && name[4] == 'N')
-                global = TRUE;
+                return 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;
+                return 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;
+                return TRUE;
             break;
         }
+    }
+    /* *{""}, or a special variable like $@ */
+    else
+        return TRUE;
+    
+    return FALSE;
+}
+
+
+/* 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 (global)
-            *stash = PL_defstash;
-        else if (IN_PERL_COMPILETIME) {
+    if ( gv_is_in_main(name, len, is_utf8) ) {
+        *stash = PL_defstash;
+    }
+    else {
+        if (IN_PERL_COMPILETIME) {
             *stash = PL_curstash;
             if (add && (PL_hints & HINT_STRICT_VARS) &&
                 sv_type != SVt_PVCV &&
@@ -1597,9 +1611,6 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len,
             *stash = CopSTASH(PL_curcop);
         }
     }
-    /* *{""}, or a special variable like $@ */
-    else
-        *stash = PL_defstash;
 
     if (!*stash) {
         if (add && !PL_in_clean_all) {
diff --git a/proto.h b/proto.h
index bc09541224..790c885538 100644
--- a/proto.h
+++ b/proto.h
@@ -5729,6 +5729,11 @@ STATIC void	S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type)
 #define PERL_ARGS_ASSERT_GV_INIT_SVTYPE	\
 	assert(gv)
 
+STATIC bool	S_gv_is_in_main(pTHX_ const char *name, STRLEN len, const U32 is_utf8)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_GV_IS_IN_MAIN	\
+	assert(name)
+
 STATIC bool	S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, bool addmg, svtype sv_type)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2)