Fix up Peek.t

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index c1b1639..7cc2c1e 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -21,7 +21,6 @@
 
 /*
 =head1 GV Functions
-
 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
 It is a structure that holds a pointer to a scalar, an array, a hash etc,
 corresponding to $foo, @foo, %foo.
@@ -102,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;
@@ -153,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));
@@ -233,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));
@@ -330,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))
@@ -353,6 +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));
+
        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
 
@@ -1693,7 +1711,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
            case 'b':
                if (len == 1 && sv_type == SVt_PV)
                    GvMULTI_on(gv);
-               /* FALL THROUGH */
+               /* FALLTHROUGH */
            default:
                goto try_core;
            }
@@ -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;
            }
            }
@@ -1968,7 +1986,7 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len,
        case '\023':    /* $^S */
        ro_magicalize:
            SvREADONLY_on(GvSVn(gv));
-           /* FALL THROUGH */
+           /* FALLTHROUGH */
        case '0':               /* $0 */
        case '^':               /* $^ */
        case '~':               /* $~ */
@@ -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,9 +2278,7 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain
 void
 Perl_gv_check(pTHX_ HV *stash)
 {
-    dVAR;
     I32 i;
-    struct xpvhv_aux *aux;
 
     PERL_ARGS_ASSERT_GV_CHECK;
 
@@ -2271,12 +2286,11 @@ Perl_gv_check(pTHX_ HV *stash)
        return;
 
     assert(SvOOK(stash));
-    aux = HvAUX(stash);
 
     for (i = 0; i <= (I32) HvMAX(stash); i++) {
         const HE *entry;
         /* mark stash is being scanned, to avoid recursing */
-        aux->xhv_aux_flags |= HvAUXf_SCAN_STASH;
+        HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH;
        for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
             GV *gv;
             HV *hv;
@@ -2310,14 +2324,13 @@ Perl_gv_check(pTHX_ HV *stash)
                             HEKfARG(GvNAME_HEK(gv)));
            }
        }
-        aux->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
+        HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH;
     }
 }
 
 GV *
 Perl_newGVgen_flags(pTHX_ const char *pack, U32 flags)
 {
-    dVAR;
     PERL_ARGS_ASSERT_NEWGVGEN_FLAGS;
     assert(!(flags & ~SVf_UTF8));
 
@@ -2332,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++;
@@ -2352,7 +2364,6 @@ Perl_gp_ref(pTHX_ GP *gp)
 void
 Perl_gp_free(pTHX_ GV *gv)
 {
-    dVAR;
     GP* gp;
     int attempts = 100;
 
@@ -2401,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);
@@ -2466,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);
@@ -2493,7 +2503,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
   {
     int filled = 0;
     int i;
-    struct xpvhv_aux *aux;
     bool deref_seen = 0;
 
 
@@ -2527,9 +2536,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
     }
 
     assert(SvOOK(stash));
-    aux = HvAUX(stash);
     /* initially assume the worst */
-    aux->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
+    HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
 
     for (i = 1; i < NofAMmeth; i++) {
        const char * const cooky = PL_AMG_names[i];
@@ -2548,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
@@ -2612,8 +2620,10 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
         }
     }
     if (!deref_seen)
-        /* none of @{} etc overloaded; we can do $obj->[N] quicker */
-        aux->xhv_aux_flags |= HvAUXf_NO_DEREF;
+        /* none of @{} etc overloaded; we can do $obj->[N] quicker.
+         * NB - aux var invalid here, HvARRAY() could have been
+         * reallocated since it was assigned to */
+        HvAUX(stash)->xhv_aux_flags |= HvAUXf_NO_DEREF;
 
     if (filled) {
       AMT_AMAGIC_on(&amt);
@@ -2634,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;
@@ -2686,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;
@@ -2729,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;
@@ -2971,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:
@@ -2979,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;
         }
@@ -3046,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;