pp.c:pp_clonecv: Use find_runcv to find the padname

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index c4089cd..01ed1f5 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -83,6 +83,9 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
 
     if (!*where)
        *where = newSV_type(type);
+    if (type == SVt_PVAV && GvNAMELEN(gv) == 3
+     && strnEQ(GvNAME(gv), "ISA", 3))
+       sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0);
     return gv;
 }
 
@@ -204,6 +207,7 @@ void
 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
 {
     GV * const oldgv = CvGV(cv);
+    HEK *hek;
     PERL_ARGS_ASSERT_CVGV_SET;
 
     if (oldgv == gv)
@@ -218,8 +222,9 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
            sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
        }
     }
+    else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek);
 
-    SvANY(cv)->xcv_gv = gv;
+    SvANY(cv)->xcv_gv_u.xcv_gv = gv;
     assert(!CvCVGV_RC(cv));
 
     if (!gv)
@@ -689,10 +694,12 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
     }
 
     packlen = HvNAMELEN_get(stash);
-    if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
+    if ((packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER"))
+     || (packlen == 5 && strEQ(hvname, "SUPER"))) {
         HV* basestash;
-        packlen -= 7;
-        basestash = gv_stashpvn(hvname, packlen,
+        basestash = packlen == 5
+                    ? PL_defstash
+                    : gv_stashpvn(hvname, packlen - 7,
                                 GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
         linear_av = mro_get_linear_isa(basestash);
     }
@@ -916,7 +923,7 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
     GvMULTI_on(gv);
     sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
     av_push(superisa, newSVhek(CopSTASH(PL_curcop)
-                              ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
+                              ? HvENAME_HEK(CopSTASH(PL_curcop)) : NULL));
 
     return stash;
 }
@@ -954,7 +961,7 @@ GV *
 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
 {
     dVAR;
-    register const char *nend;
+    const char *nend;
     const char *nsplit = NULL;
     GV* gv;
     HV* ostash = stash;
@@ -989,12 +996,12 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
            /* ->SUPER::method should really be looked up in original stash */
            SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_
                     "%"HEKf"::SUPER",
-                     HEKfARG(HvNAME_HEK((HV*)CopSTASH(PL_curcop)))
+                     HEKfARG(HvENAME_HEK((HV*)CopSTASH(PL_curcop)))
            ));
            /* __PACKAGE__::SUPER stash should be autovivified */
            stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr));
            DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
-                        origname, HvNAME_get(stash), name) );
+                        origname, HvENAME_get(stash), name) );
        }
        else {
             /* don't autovifify if ->NoSuchStash::method */
@@ -1223,6 +1230,8 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
     }
     LEAVE;
     varsv = GvSVn(vargv);
+    SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
+    /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
     sv_setsv(varsv, packname);
     sv_catpvs(varsv, "::");
     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
@@ -1310,6 +1319,16 @@ created if it does not already exist.  If the package does not exist and
 C<flags> is 0 (or any other setting that does not create packages) then NULL
 is returned.
 
+Flags may be one of:
+
+    GV_ADD
+    SVf_UTF8
+    GV_NOADD_NOINIT
+    GV_NOINIT
+    GV_NOEXPAND
+    GV_ADDMG
+
+The most important of which are probably GV_ADD and SVf_UTF8.
 
 =cut
 */
@@ -1405,11 +1424,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                       const svtype sv_type)
 {
     dVAR;
-    register const char *name = nambeg;
-    register GV *gv = NULL;
+    const char *name = nambeg;
+    GV *gv = NULL;
     GV**gvp;
     I32 len;
-    register const char *name_cursor;
+    const char *name_cursor;
     HV *stash = NULL;
     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
     const I32 no_expand = flags & GV_NOEXPAND;
@@ -1640,12 +1659,23 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                    require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
              }
              if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
-              if (*name == '[')
-               require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
-              else if (*name == '&' || *name == '`' || *name == '\'') {
-               PL_sawampersand = TRUE;
-               (void)GvSVn(gv);
-              }
+                switch (*name) {
+               case '[':
+                   require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+                    break;
+               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;
+                }
              }
            }
            else if (len == 3 && sv_type == SVt_PVAV
@@ -1851,7 +1881,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                sv_type == SVt_PVCV ||
                sv_type == SVt_PVFM ||
                sv_type == SVt_PVIO
-               )) { PL_sawampersand = TRUE; }
+               )) { PL_sawampersand |=
+                        (*name == '`')
+                            ? SAWAMPERSAND_LEFT
+                            : (*name == '&')
+                                ? SAWAMPERSAND_MIDDLE
+                                : SAWAMPERSAND_RIGHT;
+                }
            goto magicalize;
 
        case ':':               /* $: */
@@ -2042,7 +2078,7 @@ void
 Perl_gv_check(pTHX_ const HV *stash)
 {
     dVAR;
-    register I32 i;
+    I32 i;
 
     PERL_ARGS_ASSERT_GV_CHECK;
 
@@ -2051,7 +2087,7 @@ Perl_gv_check(pTHX_ const HV *stash)
     for (i = 0; i <= (I32) HvMAX(stash); i++) {
         const HE *entry;
        for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
-            register GV *gv;
+            GV *gv;
             HV *hv;
            if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
                (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
@@ -2275,9 +2311,18 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
     }
 #endif
     else if (SvTRUE(sv))
+        /* don't need to set overloading here because fallback => 1
+         * is the default setting for classes without overloading */
        amt.fallback=AMGfallYES;
-    else if (SvOK(sv))
+    else if (SvOK(sv)) {
        amt.fallback=AMGfallNEVER;
+        filled = 1;
+        have_ovl = 1;
+    }
+    else {
+        filled = 1;
+        have_ovl = 1;
+    }
 
     for (i = 1; i < lim; i++)
        amt.table[i] = NULL;