gv.c: add a require_tie_mod_s() wrapper for constant string args

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index b0221e0..0994dee 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1010,11 +1010,9 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
 {
     const char * const origname = name;
     const char * const name_end = name + len;
-    const char *nend;
-    const char *nsplit = NULL;
+    const char *last_separator = NULL;
     GV* gv;
     HV* ostash = stash;
-    const char * const origname = name;
     SV *const error_report = MUTABLE_SV(stash);
     const U32 autoload = flags & GV_AUTOLOAD;
     const U32 do_croak = flags & GV_CROAK;
@@ -1025,38 +1023,55 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
     if (SvTYPE(stash) < SVt_PVHV)
        stash = NULL;
     else {
-       /* The only way stash can become NULL later on is if nsplit is set,
+       /* The only way stash can become NULL later on is if last_separator is set,
           which in turn means that there is no need for a SVt_PVHV case
           the error reporting code.  */
     }
 
-    for (nend = name; *nend || nend != name_end; nend++) {
-       if (*nend == '\'') {
-           nsplit = nend;
-           name = nend + 1;
-       }
-       else if (*nend == ':' && *(nend + 1) == ':') {
-           nsplit = nend++;
-           name = nend + 1;
-       }
+    {
+        /* check if the method name is fully qualified or
+         * not, and separate the package name from the actual
+         * method name.
+         *
+         * leaves last_separator pointing to the beginning of the
+         * last package separator (either ' or ::) or 0
+         * if none was found.
+         *
+         * leaves name pointing at the beginning of the
+         * method name.
+         */
+        const char *name_cursor = name;
+        const char * const name_em1 = name_end - 1; /* name_end minus 1 */
+        for (name_cursor = name; name_cursor < name_end ; name_cursor++) {
+            if (*name_cursor == '\'') {
+                last_separator = name_cursor;
+                name = name_cursor + 1;
+            }
+            else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') {
+                last_separator = name_cursor++;
+                name = name_cursor + 1;
+            }
+        }
     }
-    if (nsplit) {
-       if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
+
+    /* did we find a separator? */
+    if (last_separator) {
+       if ((last_separator - origname) == 5 && memEQ(origname, "SUPER", 5)) {
            /* ->SUPER::method should really be looked up in original stash */
            stash = CopSTASH(PL_curcop);
            flags |= GV_SUPER;
            DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
                         origname, HvENAME_get(stash), name) );
        }
-       else if ((nsplit - origname) >= 7 &&
-                strnEQ(nsplit - 7, "::SUPER", 7)) {
+       else if ((last_separator - origname) >= 7 &&
+                strnEQ(last_separator - 7, "::SUPER", 7)) {
             /* don't autovifify if ->NoSuchStash::SUPER::method */
-           stash = gv_stashpvn(origname, nsplit - origname - 7, is_utf8);
+           stash = gv_stashpvn(origname, last_separator - origname - 7, is_utf8);
            if (stash) flags |= GV_SUPER;
        }
        else {
             /* don't autovifify if ->NoSuchStash::method */
-            stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
+            stash = gv_stashpvn(origname, last_separator - origname, is_utf8);
        }
        ostash = stash;
     }
@@ -1099,8 +1114,8 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
            else {
                 SV* packnamesv;
 
-               if (nsplit) {
-                   packnamesv = newSVpvn_flags(origname, nsplit - origname,
+               if (last_separator) {
+                   packnamesv = newSVpvn_flags(origname, last_separator - origname,
                                                     SVs_TEMP | is_utf8);
                } else {
                    packnamesv = error_report;
@@ -1355,6 +1370,13 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name,
     }
 }
 
+/* add a require_tie_mod_s - the _s suffix is similar to pvs type suffixes,
+ * IOW it means we do STR_WITH_LEN() ourselves and the user should pass in
+ * a true string WITHOUT a len.
+ */
+#define require_tie_mod_s(gv, varname, name, flags) \
+    S_require_tie_mod(aTHX_ gv, varname, STR_WITH_LEN(name), flags)
+
 /*
 =for apidoc gv_stashpv
 
@@ -2077,13 +2099,13 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
 
            sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
 
-            /* magicalization must be done before require_tie_mod is called */
+            /* magicalization must be done before require_tie_mod_s is called */
            if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
-               require_tie_mod(gv, '!', "Errno", 5, 1);
+                require_tie_mod_s(gv, '!', "Errno", 1);
 
            break;
-       case '-':               /* $- */
-       case '+':               /* $+ */
+       case '-':               /* $-, %-, @- */
+       case '+':               /* $+, %+, @+ */
        GvMULTI_on(gv); /* no used once warnings here */
         {
             AV* const av = GvAVn(gv);
@@ -2096,7 +2118,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
             SvREADONLY_on(av);
 
             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
-                require_tie_mod(gv, *name, "Tie::Hash::NamedCapture",23,0);
+                require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture",0);
 
             break;
        }
@@ -2116,7 +2138,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
        case '[':               /* $[ */
            if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
             && FEATURE_ARYBASE_IS_ENABLED) {
-               require_tie_mod(gv,'[',"arybase",7,0);
+                require_tie_mod_s(gv,'[',"arybase",0);
            }
            else goto magicalize;
             break;
@@ -2210,9 +2232,9 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
 
     if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) {
         if (*name == '!')
-            require_tie_mod(gv, '!', "Errno", 5, 1);
+            require_tie_mod_s(gv, '!', "Errno", 1);
         else if (*name == '-' || *name == '+')
-            require_tie_mod(gv, *name, "Tie::Hash::NamedCapture", 23, 0);
+            require_tie_mod_s(gv, *name, "Tie::Hash::NamedCapture", 0);
     } else if (sv_type == SVt_PV) {
         if (*name == '*' || *name == '#') {
             /* diag_listed_as: $* is no longer supported */
@@ -2224,7 +2246,7 @@ S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type)
     if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
       switch (*name) {
       case '[':
-          require_tie_mod(gv,'[',"arybase",7,0);
+          require_tie_mod_s(gv,'[',"arybase",0);
           break;
 #ifdef PERL_SAWAMPERSAND
       case '`':