Avoid vivifying stuff when looking up barewords

Till now, when a bareword was looked up to see whether it was a sub-
routine, an rv2cv op was created (to allow PL_check hooks to override
the process), which was then asked for its GV.

Afterwards, the GV was downgraded back to nothing if possible.

So a lot of the time a GV was autovivified and then discarded.  This
has been the case since f74617600 (5.12).

If we know there is a good chance that the rv2cv op is about to be
deleted, we can avoid that by passing a flag to the new op.

Also f74617600 actually changed the behaviour by vivifying stashes
that used not be vivified:

sub foo { print shift, "\n" }
SUPER::foo bar if 0;
foo SUPER;

Output in 5.10:

    SUPER

Output as of this commit:

    SUPER

Output in 5.12 to 5.21.3:

    Can't locate object method "foo" via package "SUPER" at - line 3.

diff --git a/op.c b/op.c
index abeea58..02ace5d 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7147,6 +7147,7 @@ Perl_cv_const_sv_or_av(const CV * const cv)
 {
     if (!cv)
        return NULL;
+    if (SvROK(cv)) return SvRV((SV *)cv);
     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
 }
@@ -8830,6 +8831,10 @@ Perl_ck_rvconst(pTHX_ OP *o)
 
     if (kid->op_type == OP_CONST) {
        int iscv;
+       const int noexpand = o->op_type == OP_RV2CV
+                         && o->op_private & OPpMAY_RETURN_CONSTANT
+                               ? GV_NOEXPAND
+                               : 0;
        GV *gv;
        SV * const kidsv = kid->op_sv;
 
@@ -8870,7 +8875,9 @@ Perl_ck_rvconst(pTHX_ OP *o)
        iscv = (o->op_type == OP_RV2CV) * 2;
        do {
            gv = gv_fetchsv(kidsv,
-               iscv | !(kid->op_private & OPpCONST_ENTERED),
+               noexpand
+                   ? noexpand
+                   : iscv | !(kid->op_private & OPpCONST_ENTERED),
                iscv
                    ? SVt_PVCV
                    : o->op_type == OP_RV2SV
@@ -8880,7 +8887,8 @@ Perl_ck_rvconst(pTHX_ OP *o)
                            : o->op_type == OP_RV2HV
                                ? SVt_PVHV
                                : SVt_PVGV);
-       } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
+       } while (!noexpand && !gv && !(kid->op_private & OPpCONST_ENTERED)
+             && !iscv++);
        if (gv) {
            kid->op_type = OP_GV;
            SvREFCNT_dec(kid->op_sv);
@@ -8889,7 +8897,7 @@ Perl_ck_rvconst(pTHX_ OP *o)
            assert (sizeof(PADOP) <= sizeof(SVOP));
            kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
            SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
-           GvIN_PAD_on(gv);
+           if (isGV(gv)) GvIN_PAD_on(gv);
            PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
 #else
            kid->op_sv = SvREFCNT_inc_simple_NN(gv);
@@ -10077,7 +10085,7 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
     CV *cv;
     GV *gv;
     PERL_ARGS_ASSERT_RV2CV_OP_CV;
-    if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
+    if (flags & ~RV2CVOPCV_FLAG_MASK)
        Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
     if (cvop->op_type != OP_RV2CV)
        return NULL;
@@ -10089,6 +10097,11 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
     switch (rvop->op_type) {
        case OP_GV: {
            gv = cGVOPx_gv(rvop);
+           if (!isGV(gv)) {
+               if (flags & RV2CVOPCV_RETURN_STUB)
+                   return (CV *)gv;
+               else return NULL;
+           }
            cv = GvCVu(gv);
            if (!cv) {
                if (flags & RV2CVOPCV_MARK_EARLY)

diff --git a/op.h b/op.h
index c76f37d..6070326 100644 (file)
--- a/op.h
+++ b/op.h
@@ -214,13 +214,13 @@ is no conversion of op type.
 
   bit  entersub flag       phase   rv2cv flag             phase
   ---  -------------       -----   ----------             -----
-    1  OPpENTERSUB_INARGS  context OPpMAY_RETURN_CONSTANT context
+    1  OPpENTERSUB_INARGS  context
     2  HINT_STRICT_REFS    check   HINT_STRICT_REFS       check
     4  OPpENTERSUB_HASTARG check
     8                              OPpENTERSUB_AMPER      parser
    16  OPpENTERSUB_DB      check
    32  OPpDEREF_AV         context
-   64  OPpDEREF_HV         context
+   64  OPpDEREF_HV         context OPpMAY_RETURN_CONSTANT context
   128  OPpLVAL_INTRO       context OPpENTERSUB_NOPAREN    parser
 
 */
@@ -238,7 +238,7 @@ is no conversion of op type.
   /* OP_RV2CV only */
 #define OPpENTERSUB_AMPER      8       /* Used & form to call. */
 #define OPpENTERSUB_NOPAREN    128     /* bare sub call (without parens) */
-#define OPpMAY_RETURN_CONSTANT 1       /* If a constant sub, return the constant */
+#define OPpMAY_RETURN_CONSTANT 64      /* If a constant sub, return the constant */
 
   /* OP_GV only */
 #define OPpEARLY_CV            32      /* foo() called before sub foo was parsed */
@@ -878,6 +878,8 @@ preprocessing token; the type of I<arg> depends on I<which>.
 
 #define RV2CVOPCV_MARK_EARLY     0x00000001
 #define RV2CVOPCV_RETURN_NAME_GV 0x00000002
+#define RV2CVOPCV_RETURN_STUB    0x00000004
+#define RV2CVOPCV_FLAG_MASK      0x00000007 /* all of the above */
 
 #define op_lvalue(op,t) Perl_op_lvalue_flags(aTHX_ op,t,0)
 

diff --git a/t/op/stash.t b/t/op/stash.t
index 5988114..4c846b7 100644 (file)
--- a/t/op/stash.t
+++ b/t/op/stash.t
@@ -7,7 +7,7 @@ BEGIN {
 
 BEGIN { require "./test.pl"; }
 
-plan( tests => 49 );
+plan( tests => 50 );
 
 # Used to segfault (bug #15479)
 fresh_perl_like(
@@ -318,3 +318,12 @@ ok eval '
      sub foo{};
      1
   ', 'no crashing or errors when clobbering the current package';
+
+# Bareword lookup should not vivify stashes
+is runperl(
+    prog =>
+      'sub foo { print shift, qq-\n- } SUPER::foo bar if 0; foo SUPER',
+    stderr => 1,
+   ),
+   "SUPER\n",
+   'bareword lookup does not vivify stashes';

diff --git a/toke.c b/toke.c
index 98fd125..4e7ae3b 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -6560,8 +6560,11 @@ Perl_yylex(pTHX)
                {
                    OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
                    const_op->op_private = OPpCONST_BARE;
-                   rv2cv_op = newCVREF(0, const_op);
-                   cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
+                   rv2cv_op =
+                       newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
+                   cv = lex
+                       ? GvCV(gv)
+                       : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
                }
 
                /* See if it's the indirect object for a list operator. */
@@ -6675,6 +6678,7 @@ Perl_yylex(pTHX)
                /* Not a method, so call it a subroutine (if defined) */
 
                if (cv) {
+                   OP *gvop;
                    if (lastchar == '-' && penultchar != '-') {
                        const STRLEN l = len ? len : strlen(PL_tokenbuf);
                        Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
@@ -6699,6 +6703,20 @@ Perl_yylex(pTHX)
                        TOKEN(WORD);
                    }
 
+                   /* Resolve to GV now if this is a placeholder. */
+                   if ((gvop = cUNOPx(rv2cv_op)->op_first)
+                    && gvop->op_type == OP_GV) {
+                       GV *gv2 = cGVOPx_gv(gvop);
+                       if (gv2 && !isGV(gv2)) {
+                           gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
+                           assert (SvTYPE(gv) == SVt_PVGV);
+                           /* cv must have been some sort of placeholder,
+                              so now needs replacing with a real code
+                              reference.  */
+                           cv = GvCV(gv);
+                       }
+                   }
+
                    op_free(pl_yylval.opval);
                    pl_yylval.opval =
                        off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;