gv.c, gv_fetchpvn_flags: Split another chunk of magic-checking code.

This bit is called when a GV already exists, but it's name is length-one
and it's on the main:: stash, so it might have multiple kinds of magic,
like $! and %!, or @+ and %+.

diff --git a/embed.fnc b/embed.fnc
index de80406..a09fce9 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1787,6 +1787,7 @@ s  |bool|find_default_stash|NN HV **stash|NN const char *name \
 s  |GV*|magicalize_gv|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      |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 da06534..23cd8c5 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1382,6 +1382,7 @@
 #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 magicalize_gv(a,b,c,d,e,f)     S_magicalize_gv(aTHX_ a,b,c,d,e,f)
+#define maybe_multimagic_gv(a,b,c)     S_maybe_multimagic_gv(aTHX_ a,b,c)
 #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

diff --git a/gv.c b/gv.c
index 49e8830..29bf398 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -2008,6 +2008,53 @@ S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
     return gv;
 }
 
+/* This function is called when the stash already holds the GV of the magic
+ * variable we're looking for, but we need to check that it has the correct
+ * kind of magic.  For example, if someone first uses $! and then %!, the
+ * latter would end up here, and we add the Errno tie to the HASH slot of
+ * the *! glob.
+ */
+PERL_STATIC_INLINE void
+S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
+{
+    PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV;
+
+    if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
+        if (*name == '!')
+            require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+        else if (*name == '-' || *name == '+')
+            require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+    } else if (sv_type == SVt_PV) {
+        if (*name == '*' || *name == '#') {
+            /* diag_listed_as: $* is no longer supported */
+            Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
+                                             WARN_SYNTAX),
+                             "$%c is no longer supported", *name);
+        }
+    }
+    if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
+      switch (*name) {
+      case '[':
+          require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+          break;
+#ifdef PERL_SAWAMPERSAND
+      case '`':
+          PL_sawampersand |= SAWAMPERSAND_LEFT;
+          (void)GvSVn(gv);
+          break;
+      case '&':
+          PL_sawampersand |= SAWAMPERSAND_MIDDLE;
+          (void)GvSVn(gv);
+          break;
+      case '\'':
+          PL_sawampersand |= SAWAMPERSAND_RIGHT;
+          (void)GvSVn(gv);
+          break;
+#endif
+      }
+    }
+}
+
 GV *
 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                       const svtype sv_type)
@@ -2077,40 +2124,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                exist, then (say) referencing $! first, and %! second would
                mean that %! was not handled correctly.  */
            if (len == 1 && stash == PL_defstash) {
-             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
-               if (*name == '!')
-                   require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
-               else if (*name == '-' || *name == '+')
-                   require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
-              } else if (sv_type == SVt_PV) {
-                  if (*name == '*' || *name == '#') {
-                      /* diag_listed_as: $* is no longer supported */
-                      Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,
-                                                       WARN_SYNTAX),
-                                       "$%c is no longer supported", *name);
-                  }
-              }
-             if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
-                switch (*name) {
-               case '[':
-                   require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
-                    break;
-#ifdef PERL_SAWAMPERSAND
-               case '`':
-                   PL_sawampersand |= SAWAMPERSAND_LEFT;
-                    (void)GvSVn(gv);
-                    break;
-               case '&':
-                   PL_sawampersand |= SAWAMPERSAND_MIDDLE;
-                    (void)GvSVn(gv);
-                    break;
-               case '\'':
-                   PL_sawampersand |= SAWAMPERSAND_RIGHT;
-                    (void)GvSVn(gv);
-                    break;
-#endif
-                }
-             }
+                maybe_multimagic_gv(gv, name, sv_type);
            }
            else if (len == 3 && sv_type == SVt_PVAV
                  && strnEQ(name, "ISA", 3)

diff --git a/proto.h b/proto.h
index be3a9fa..4cb3e47 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5741,6 +5741,12 @@ STATIC GV*       S_magicalize_gv(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len
 #define PERL_ARGS_ASSERT_MAGICALIZE_GV \
        assert(gv); assert(stash); assert(name)
 
+STATIC void    S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAYBE_MULTIMAGIC_GV   \
+       assert(gv); assert(name)
+
 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)