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 07709a0..0994dee 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1010,7 +1010,6 @@ 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 *last_separator = NULL;
     GV* gv;
     HV* ostash = stash;
@@ -1029,16 +1028,33 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
           the error reporting code.  */
     }
 
-    for (nend = name; *nend || nend != name_end; nend++) {
-       if (*nend == '\'') {
-           last_separator = nend;
-           name = nend + 1;
-       }
-       else if (*nend == ':' && *(nend + 1) == ':') {
-           last_separator = 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;
+            }
+        }
     }
+
+    /* 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 */
@@ -1354,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
 
@@ -2076,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);
@@ -2095,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;
        }
@@ -2115,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;
@@ -2209,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 */
@@ -2223,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 '`':