Bareword sub lookups

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index 3df4e27..932b2b8 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -413,9 +413,8 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
         cstash = gv_stashsv(linear_sv, 0);
 
         if (!cstash) {
-            if (ckWARN(WARN_SYNTAX))
-                Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
-                    SVfARG(linear_sv), hvname);
+           Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
+                          SVfARG(linear_sv), hvname);
             continue;
         }
 
@@ -729,11 +728,10 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
      * Inheriting AUTOLOAD for non-methods works ... for now.
      */
     if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
-       && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
     )
-       Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-         "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
-            packname, (int)len, name);
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+                        "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
+                        packname, (int)len, name);
 
     if (CvISXSUB(cv)) {
         /* rather than lookup/init $AUTOLOAD here
@@ -1139,8 +1137,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
     faking_it = SvOK(gv);
 
-    if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
-       Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
+    if (add & GV_ADDWARN)
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
     gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
 
@@ -1352,9 +1350,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
        }
        case '*':
        case '#':
-           if (sv_type == SVt_PV && ckWARN2_d(WARN_DEPRECATED, WARN_SYNTAX))
-               Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-                           "$%c is no longer supported", *name);
+           if (sv_type == SVt_PV)
+               Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+                                "$%c is no longer supported", *name);
            break;
        case '|':
            sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
@@ -1561,10 +1559,9 @@ Perl_gp_free(pTHX_ GV *gv)
     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
        return;
     if (gp->gp_refcnt == 0) {
-       if (ckWARN_d(WARN_INTERNAL))
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                       "Attempt to free unreferenced glob pointers"
-                        pTHX__FORMAT pTHX__VALUE);
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+                        "Attempt to free unreferenced glob pointers"
+                        pTHX__FORMAT pTHX__VALUE);
         return;
     }
     if (--gp->gp_refcnt > 0) {
@@ -1966,6 +1963,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
         case int_amg:
         case iter_amg:                 /* XXXX Eventually should do to_gv. */
         case ftest_amg:                /* XXXX Eventually should do to_gv. */
+        case regexp_amg:
             /* FAIL safe */
             return NULL;       /* Delegate operation to standard mechanisms. */
             break;
@@ -2374,6 +2372,53 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
 }
 
 /*
+=for apidoc gv_try_downgrade
+
+If C<gv> is a typeglob containing only a constant sub, and is only
+referenced from its package, and both the typeglob and the sub are
+sufficiently ordinary, replace the typeglob (in the package) with a
+placeholder that more compactly represents the same thing.  This is meant
+to be used when a placeholder has been upgraded, most likely because
+something wanted to look at a proper code object, and it has turned out
+to be a constant sub to which a proper reference is no longer required.
+
+=cut
+*/
+
+void
+Perl_gv_try_downgrade(pTHX_ GV *gv)
+{
+    HV *stash;
+    CV *cv;
+    HEK *namehek;
+    SV **gvp;
+    PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
+    if (SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
+           !SvOBJECT(gv) && !SvMAGICAL(gv) && !SvREADONLY(gv) &&
+           isGV_with_GP(gv) && GvGP(gv) &&
+           GvMULTI(gv) && !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
+           !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
+           GvEGV(gv) == gv && (stash = GvSTASH(gv)) && (cv = GvCV(gv)) &&
+           !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
+           CvSTASH(cv) == stash && CvGV(cv) == gv &&
+           CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
+           !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
+           (namehek = GvNAME_HEK(gv)) &&
+           (gvp = hv_fetch(stash, HEK_KEY(namehek),
+                       HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
+           *gvp == (SV*)gv) {
+       SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
+       SvREFCNT(gv) = 0;
+       sv_clear((SV*)gv);
+       SvREFCNT(gv) = 1;
+       SvFLAGS(gv) = SVt_IV|SVf_ROK;
+       SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
+                               STRUCT_OFFSET(XPVIV, xiv_iv));
+       SvRV_set(gv, value);
+    }
+}
+
+/*
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4