Fix up Peek.t

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index d8cc012..7cc2c1e 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -101,7 +101,6 @@ GV *
 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
                        const U32 flags)
 {
-    dVAR;
     char smallbuf[128];
     char *tmpbuf;
     const STRLEN tmplen = namelen + 2;
@@ -152,6 +151,7 @@ SV *
 Perl_gv_const_sv(pTHX_ GV *gv)
 {
     PERL_ARGS_ASSERT_GV_CONST_SV;
+    PERL_UNUSED_CONTEXT;
 
     if (SvTYPE(gv) == SVt_PVGV)
        return cv_const_sv(GvCVu(gv));
@@ -232,7 +232,10 @@ 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);
+    else if ((hek = CvNAME_HEK(cv))) {
+       unshare_hek(hek);
+       CvNAMED_off(cv);
+    }
 
     SvANY(cv)->xcv_gv_u.xcv_gv = gv;
     assert(!CvCVGV_RC(cv));
@@ -329,7 +332,6 @@ Perl_gv_init_pv(pTHX_ GV *gv, HV *stash, const char *name, U32 flags)
 void
 Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flags)
 {
-    dVAR;
     const U32 old_type = SvTYPE(gv);
     const bool doproto = old_type > SVt_NULL;
     char * const proto = (doproto && SvPOK(gv))
@@ -352,7 +354,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
        case SVt_PVIO:
             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
                       sv_reftype(has_constant, 0));
-            break;
+
        default: NOOP;
        }
        SvRV_set(gv, NULL);
@@ -644,7 +646,6 @@ obtained from the GV with the C<GvCV> macro.
 GV *
 Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 {
-    dVAR;
     GV** gvp;
     AV* linear_av;
     SV** linear_svp;
@@ -947,7 +948,6 @@ Perl_gv_fetchmethod_pv_flags(pTHX_ HV *stash, const char *name, U32 flags)
 GV *
 Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN len, U32 flags)
 {
-    dVAR;
     const char *nend;
     const char *nsplit = NULL;
     GV* gv;
@@ -1097,7 +1097,6 @@ Perl_gv_autoload_pv(pTHX_ HV *stash, const char *namepv, U32 flags)
 GV*
 Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
 {
-    dVAR;
     GV* gv;
     CV* cv;
     HV* varstash;
@@ -1202,7 +1201,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
      * use that, but for lack of anything better we will use the sub's
      * original package to look up $AUTOLOAD.
      */
-    varstash = GvSTASH(CvGV(cv));
+    varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv));
     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
     ENTER;
 
@@ -1245,7 +1244,6 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
 STATIC HV*
 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
 {
-    dVAR;
     HV* stash = gv_stashsv(namesv, 0);
 
     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
@@ -1318,8 +1316,8 @@ The most important of which are probably GV_ADD and SVf_UTF8.
 =cut
 */
 
-HV*
-Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
+PERL_STATIC_INLINE HV*
+S_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
 {
     char smallbuf[128];
     char *tmpbuf;
@@ -1356,6 +1354,26 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
     return stash;
 }
 
+HV*
+Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
+{
+    HV* stash;
+    const HE* const he = (const HE *)hv_common(
+        PL_stashcache, NULL, name, namelen,
+        (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0
+    );
+    if (he) return INT2PTR(HV*,SvIVX(HeVAL(he)));
+    else if (flags & GV_CACHE_ONLY) return NULL;
+
+    stash = S_stashpvn(aTHX_ name, namelen, flags);
+    if (stash && namelen) {
+        SV* const ref = newSViv(PTR2IV(stash));
+        hv_store(PL_stashcache, name,
+            (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0);
+    }
+    return stash;
+}
+
 /*
 =for apidoc gv_stashsv
 
@@ -1848,7 +1866,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
                    if (!isDIGIT(*end))
                         return addmg;
                }
-                paren = strtoul(name, NULL, 10);
+                paren = grok_atou(name, NULL);
                 goto storeparen;
            }
            }
@@ -2083,7 +2101,6 @@ GV *
 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                       const svtype sv_type)
 {
-    dVAR;
     const char *name = nambeg;
     GV *gv = NULL;
     GV**gvp;
@@ -2261,7 +2278,6 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain
 void
 Perl_gv_check(pTHX_ HV *stash)
 {
-    dVAR;
     I32 i;
 
     PERL_ARGS_ASSERT_GV_CHECK;
@@ -2315,7 +2331,6 @@ Perl_gv_check(pTHX_ HV *stash)
 GV *
 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
 {
-    dVAR;
     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
     assert(!(flags & ~SVf_UTF8));
 
@@ -2330,7 +2345,6 @@ Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
 GP*
 Perl_gp_ref(pTHX_ GP *gp)
 {
-    dVAR;
     if (!gp)
        return NULL;
     gp->gp_refcnt++;
@@ -2350,7 +2364,6 @@ Perl_gp_ref(pTHX_ GP *gp)
 void
 Perl_gp_free(pTHX_ GV *gv)
 {
-    dVAR;
     GP* gp;
     int attempts = 100;
 
@@ -2399,7 +2412,7 @@ Perl_gp_free(pTHX_ GV *gv)
          Somehow gp->gp_hv can end up pointing at freed garbage.  */
       if (hv && SvTYPE(hv) == SVt_PVHV) {
         const HEK *hvname_hek = HvNAME_HEK(hv);
-        DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", hvname_hek));
+        DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for '%"HEKf"'\n", HEKfARG(hvname_hek)));
         if (PL_stashcache && hvname_hek)
            (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD);
        SvREFCNT_dec(hv);
@@ -2464,7 +2477,6 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
 {
-  dVAR;
   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
   AMT amt;
   const struct mro_meta* stash_meta = HvMROMETA(stash);
@@ -2544,7 +2556,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
           numifying instead of C's "+0". */
        gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0);
         cv = 0;
-        if (gv && (cv = GvCV(gv))) {
+        if (gv && (cv = GvCV(gv)) && CvGV(cv)) {
            if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){
              const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv)));
              if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8
@@ -2632,7 +2644,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
 CV*
 Perl_gv_handler(pTHX_ HV *stash, I32 id)
 {
-    dVAR;
     MAGIC *mg;
     AMT *amtp;
     U32 newgen;
@@ -2684,7 +2695,6 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
 
 bool
 Perl_try_amagic_un(pTHX_ int method, int flags) {
-    dVAR;
     dSP;
     SV* tmpsv;
     SV* const arg = TOPs;
@@ -2727,7 +2737,6 @@ Perl_try_amagic_un(pTHX_ int method, int flags) {
 
 bool
 Perl_try_amagic_bin(pTHX_ int method, int flags) {
-    dVAR;
     dSP;
     SV* const left = TOPm1s;
     SV* const right = TOPs;
@@ -2969,7 +2978,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
         case regexp_amg:
             /* FAIL safe */
             return NULL;       /* Delegate operation to standard mechanisms. */
-            break;
+
         case to_sv_amg:
         case to_av_amg:
         case to_hv_amg:
@@ -2977,7 +2986,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
         case to_cv_amg:
             /* FAIL safe */
             return left;       /* Delegate operation to standard mechanisms. */
-            break;
+
         default:
           goto not_found;
         }
@@ -3044,7 +3053,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
         case to_cv_amg:
             /* FAIL safe */
             return left;       /* Delegate operation to standard mechanisms. */
-            break;
       }
       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
        notfound = 1; lr = -1;