Fix crash when lex subs are used for overload

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index e402f6b..e4d6aca 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));
@@ -330,7 +329,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 +351,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 +643,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 +945,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 +1094,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 +1198,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 +1241,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 +1313,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 +1351,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 +1708,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 +1863,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 +1983,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 +2098,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 +2275,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 +2328,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 +2342,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 +2361,6 @@ Perl_gp_ref(pTHX_ GP *gp)
 void
 Perl_gp_free(pTHX_ GV *gv)
 {
-    dVAR;
     GP* gp;
     int attempts = 100;
 
@@ -2399,7 +2409,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 +2474,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 +2553,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 +2641,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 +2692,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 +2734,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 +2975,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 +2983,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 +3050,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;