This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
C99 math: lgamma and tgamma emulations.
[perl5.git] / op.c
diff --git a/op.c b/op.c
index a08cb6a..8a0c7fa 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1643,7 +1643,8 @@ Perl_scalarvoid(pTHX_ OP *arg)
         if ((o->op_private & OPpTARGET_MY)
             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
         {
-            scalar(o);                  /* As if inside SASSIGN */
+            /* newASSIGNOP has already applied scalar context, which we
+               leave, as if this op is inside SASSIGN.  */
             continue;
         }
 
@@ -2421,6 +2422,22 @@ such as C<$$x = 5> which might have to vivify a reference in C<$x>.
 =cut
 */
 
+static void
+S_mark_padname_lvalue(pTHX_ PADNAME *pn)
+{
+    CV *cv = PL_compcv;
+    PadnameLVALUE_on(pn);
+    while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
+       cv = CvOUTSIDE(cv);
+       assert(cv);
+       assert(CvPADLIST(cv));
+       pn =
+          PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
+       assert(PadnameLEN(pn));
+       PadnameLVALUE_on(pn);
+    }
+}
+
 static bool
 S_vivifies(const OPCODE type)
 {
@@ -2791,6 +2808,10 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
        if (!type) /* local() */
            Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
                 PAD_COMPNAME_SV(o->op_targ));
+       if (!(o->op_private & OPpLVAL_INTRO)
+        || (  type != OP_SASSIGN && type != OP_AASSIGN
+           && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
+           S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
        break;
 
     case OP_PUSHMARK:
@@ -3576,22 +3597,27 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
        right->op_targ = 0;
        right->op_private &= ~OPpTARGET_MY;
     }
-    if (!(right->op_flags & OPf_STACKED) && ismatchop) {
-       OP *newleft;
-
-       right->op_flags |= OPf_STACKED;
-       if (rtype != OP_MATCH && rtype != OP_TRANSR &&
+    if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
+        if (left->op_type == OP_PADSV
+         && !(left->op_private & OPpLVAL_INTRO))
+        {
+            right->op_targ = left->op_targ;
+            op_free(left);
+            o = right;
+        }
+        else {
+            right->op_flags |= OPf_STACKED;
+            if (rtype != OP_MATCH && rtype != OP_TRANSR &&
             ! (rtype == OP_TRANS &&
                right->op_private & OPpTRANS_IDENTICAL) &&
            ! (rtype == OP_SUBST &&
               (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
-           newleft = op_lvalue(left, rtype);
-       else
-           newleft = left;
-       if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
-           o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
-       else
-           o = op_prepend_elem(rtype, scalar(newleft), right);
+               left = op_lvalue(left, rtype);
+           if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
+               o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
+           else
+               o = op_prepend_elem(rtype, scalar(left), right);
+       }
        if (type == OP_NOT)
            return newUNOP(OP_NOT, 0, scalar(o));
        return o;
@@ -4789,9 +4815,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        UV tfirst = 1;
        UV tlast = 0;
        IV tdiff;
+       STRLEN tcount = 0;
        UV rfirst = 1;
        UV rlast = 0;
        IV rdiff;
+       STRLEN rcount = 0;
        IV diff;
        I32 none = 0;
        U32 max = 0;
@@ -4918,6 +4946,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            /* now see which range will peter our first, if either. */
            tdiff = tlast - tfirst;
            rdiff = rlast - rfirst;
+           tcount += tdiff + 1;
+           rcount += rdiff + 1;
 
            if (tdiff <= rdiff)
                diff = tdiff;
@@ -4979,15 +5009,17 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
                           newSVuv((UV)final), 0);
 
-       if (grows)
-           o->op_private |= OPpTRANS_GROWS;
-
        Safefree(tsave);
        Safefree(rsave);
 
-       op_free(expr);
-       op_free(repl);
-       return o;
+       tlen = tcount;
+       rlen = rcount;
+       if (r < rend)
+           rlen++;
+       else if (rlast == 0xffffffff)
+           rlen = 0;
+
+       goto warnins;
     }
 
     tbl = (short*)PerlMemShared_calloc(
@@ -5063,6 +5095,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        }
     }
 
+  warnins:
     if(del && rlen == tlen) {
        Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
     } else if(rlen > tlen && !complement) {
@@ -5151,6 +5184,21 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags)
     return CHECKOP(type, pmop);
 }
 
+static void
+S_set_haseval(pTHX)
+{
+    PADOFFSET i = 1;
+    PL_cv_has_eval = 1;
+    /* Any pad names in scope are potentially lvalues.  */
+    for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
+       PADNAME *pn = PAD_COMPNAME_SV(i);
+       if (!pn || !PadnameLEN(pn))
+           continue;
+       if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
+           S_mark_padname_lvalue(aTHX_ pn);
+    }
+}
+
 /* Given some sort of match op o, and an expression expr containing a
  * pattern, either compile expr into a regex and attach it to o (if it's
  * constant), or convert expr into a runtime regcomp op sequence (if it's
@@ -5443,7 +5491,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
        rcop->op_targ = cv_targ;
 
        /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
-       if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
+       if (PL_hints & HINT_RE_EVAL)
+           S_set_haseval(aTHX);
 
        /* establish postfix order */
        if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
@@ -6440,9 +6489,6 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
     }
     cop->op_flags = (U8)flags;
     CopHINTS_set(cop, PL_hints);
-#ifdef NATIVE_HINTS
-    cop->op_private |= NATIVE_HINTS;
-#endif
 #ifdef VMS
     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
 #endif
@@ -7663,51 +7709,38 @@ Perl_cv_const_sv_or_av(const CV * const cv)
 }
 
 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
- * Can be called in 3 ways:
+ * Can be called in 2 ways:
  *
- * !cv
+ * !allow_lex
  *     look for a single OP_CONST with attached value: return the value
  *
- * cv && CvCLONE(cv) && !CvCONST(cv)
+ * allow_lex && !CvCONST(cv);
  *
  *     examine the clone prototype, and if contains only a single
- *     OP_CONST referencing a pad const, or a single PADSV referencing
- *     an outer lexical, return a non-zero value to indicate the CV is
- *     a candidate for "constizing" at clone time
- *
- * cv && CvCONST(cv)
- *
- *     We have just cloned an anon prototype that was marked as a const
- *     candidate. Try to grab the current value, and in the case of
- *     PADSV, ignore it if it has multiple references. In this case we
- *     return a newly created *copy* of the value.
+ *     OP_CONST, return the value; or if it contains a single PADSV ref-
+ *     erencing an outer lexical, turn on CvCONST to indicate the CV is
+ *     a candidate for "constizing" at clone time, and return NULL.
  */
 
-SV *
-Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
+static SV *
+S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
 {
     SV *sv = NULL;
+    bool padsv = FALSE;
 
-    if (!o)
-       return NULL;
-
-    if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
-       o = OP_SIBLING(cLISTOPo->op_first);
+    assert(o);
+    assert(cv);
 
     for (; o; o = o->op_next) {
        const OPCODE type = o->op_type;
 
-       if (sv && o->op_next == o)
-           return sv;
-       if (o->op_next != o) {
-           if (type == OP_NEXTSTATE
-            || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
+       if (type == OP_NEXTSTATE || type == OP_LINESEQ
+            || type == OP_NULL
             || type == OP_PUSHMARK)
                continue;
-           if (type == OP_DBSTATE)
+       if (type == OP_DBSTATE)
                continue;
-       }
-       if (type == OP_LEAVESUB || type == OP_RETURN)
+       if (type == OP_LEAVESUB)
            break;
        if (sv)
            return NULL;
@@ -7717,31 +7750,23 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
            sv = newSV(0);
            SAVEFREESV(sv);
        }
-       else if (cv && type == OP_CONST) {
-           sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
-           if (!sv)
-               return NULL;
-       }
-       else if (cv && type == OP_PADSV) {
-           if (CvCONST(cv)) { /* newly cloned anon */
-               sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
-               /* the candidate should have 1 ref from this pad and 1 ref
-                * from the parent */
-               if (!sv || SvREFCNT(sv) != 2)
-                   return NULL;
-               sv = newSVsv(sv);
-               SvREADONLY_on(sv);
-               return sv;
-           }
-           else {
+       else if (allow_lex && type == OP_PADSV) {
                if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+               {
                    sv = &PL_sv_undef; /* an arbitrary non-null value */
-           }
+                   padsv = TRUE;
+               }
+               else
+                   return NULL;
        }
        else {
            return NULL;
        }
     }
+    if (padsv) {
+       CvCONST_on(cv);
+       return NULL;
+    }
     return sv;
 }
 
@@ -7811,6 +7836,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     CV *clonee = NULL;
     HEK *hek = NULL;
     bool reusable = FALSE;
+    OP *start;
 #ifdef PERL_DEBUG_READONLY_OPS
     OPSLAB *slab = NULL;
 #endif
@@ -7896,12 +7922,29 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        spot = (CV **)(svspot = &mg->mg_obj);
     }
 
+    if (block) {
+       /* This makes sub {}; work as expected.  */
+       if (block->op_type == OP_STUB) {
+           const line_t l = PL_parser->copline;
+           op_free(block);
+           block = newSTATEOP(0, NULL, 0);
+           PL_parser->copline = l;
+       }
+       block = CvLVALUE(compcv)
+            || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
+                  ? newUNOP(OP_LEAVESUBLV, 0,
+                            op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+                  : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+       start = LINKLIST(block);
+       block->op_next = 0;
+    }
+
     if (!block || !ps || *ps || attrs
-       || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
+       || CvLVALUE(compcv)
        )
        const_sv = NULL;
     else
-       const_sv = op_const_sv(block, NULL);
+       const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
 
     if (cv) {
         const bool exists = CvROOT(cv) || CvXSUB(cv);
@@ -7947,6 +7990,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        CvCONST_on(cv);
        CvISXSUB_on(cv);
        PoisonPADLIST(cv);
+       CvFLAGS(cv) |= CvMETHOD(compcv);
        op_free(block);
        SvREFCNT_dec(compcv);
        PL_compcv = NULL;
@@ -8043,16 +8087,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        exit.  */
        
     PL_breakable_sub_gen++;
-    /* This makes sub {}; work as expected.  */
-    if (block->op_type == OP_STUB) {
-           OP* const newblock = newSTATEOP(0, NULL, 0);
-           op_free(block);
-           block = newblock;
-    }
-    CvROOT(cv) = CvLVALUE(cv)
-                  ? newUNOP(OP_LEAVESUBLV, 0,
-                            op_lvalue(scalarseq(block), OP_LEAVESUBLV))
-                  : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+    CvROOT(cv) = block;
     CvROOT(cv)->op_private |= OPpREFCOUNTED;
     OpREFCNT_set(CvROOT(cv), 1);
     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
@@ -8062,9 +8097,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 #ifdef PERL_DEBUG_READONLY_OPS
     slab = (OPSLAB *)CvSTART(cv);
 #endif
-    CvSTART(cv) = LINKLIST(CvROOT(cv));
-    CvROOT(cv)->op_next = 0;
-    CALL_PEEP(CvSTART(cv));
+    CvSTART(cv) = start;
+    CALL_PEEP(start);
     finalize_optree(CvROOT(cv));
     S_prune_chain_head(&CvSTART(cv));
 
@@ -8072,12 +8106,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 
     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
 
-    if (CvCLONE(cv)) {
-       assert(!CvCONST(cv));
-       if (ps && !*ps && op_const_sv(block, cv))
-           CvCONST_on(cv);
-    }
-
   attrs:
     if (attrs) {
        /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
@@ -8176,6 +8204,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
         o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
     bool has_name;
     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
+    OP *start;
 #ifdef PERL_DEBUG_READONLY_OPS
     OPSLAB *slab = NULL;
     bool special = FALSE;
@@ -8296,13 +8325,31 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
                ? (CV *)SvRV(gv)
                : NULL;
 
+    if (block) {
+       /* This makes sub {}; work as expected.  */
+       if (block->op_type == OP_STUB) {
+           const line_t l = PL_parser->copline;
+           op_free(block);
+           block = newSTATEOP(0, NULL, 0);
+           PL_parser->copline = l;
+       }
+       block = CvLVALUE(PL_compcv)
+            || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
+                   && (!isGV(gv) || !GvASSUMECV(gv)))
+                  ? newUNOP(OP_LEAVESUBLV, 0,
+                            op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+                  : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+       start = LINKLIST(block);
+       block->op_next = 0;
+    }
 
     if (!block || !ps || *ps || attrs
-       || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+       || CvLVALUE(PL_compcv)
        )
        const_sv = NULL;
     else
-       const_sv = op_const_sv(block, NULL);
+       const_sv =
+           S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
 
     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
        assert (block);
@@ -8369,14 +8416,17 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            CvCONST_on(cv);
            CvISXSUB_on(cv);
            PoisonPADLIST(cv);
+           CvFLAGS(cv) |= CvMETHOD(PL_compcv);
        }
        else {
-           if (isGV(gv)) {
-               if (name) GvCV_set(gv, NULL);
+           if (isGV(gv) || CvMETHOD(PL_compcv)) {
+               if (name && isGV(gv))
+                   GvCV_set(gv, NULL);
                cv = newCONSTSUB_flags(
                    NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
                    const_sv
                );
+               CvFLAGS(cv) |= CvMETHOD(PL_compcv);
            }
            else {
                if (!SvROK(gv)) {
@@ -8502,16 +8552,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
        exit.  */
        
     PL_breakable_sub_gen++;
-    /* This makes sub {}; work as expected.  */
-    if (block->op_type == OP_STUB) {
-           OP* const newblock = newSTATEOP(0, NULL, 0);
-           op_free(block);
-           block = newblock;
-    }
-    CvROOT(cv) = CvLVALUE(cv)
-                  ? newUNOP(OP_LEAVESUBLV, 0,
-                            op_lvalue(scalarseq(block), OP_LEAVESUBLV))
-                  : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+    CvROOT(cv) = block;
     CvROOT(cv)->op_private |= OPpREFCOUNTED;
     OpREFCNT_set(CvROOT(cv), 1);
     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
@@ -8521,9 +8562,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 #ifdef PERL_DEBUG_READONLY_OPS
     slab = (OPSLAB *)CvSTART(cv);
 #endif
-    CvSTART(cv) = LINKLIST(CvROOT(cv));
-    CvROOT(cv)->op_next = 0;
-    CALL_PEEP(CvSTART(cv));
+    CvSTART(cv) = start;
+    CALL_PEEP(start);
     finalize_optree(CvROOT(cv));
     S_prune_chain_head(&CvSTART(cv));
 
@@ -8531,12 +8571,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 
     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
 
-    if (CvCLONE(cv)) {
-       assert(!CvCONST(cv));
-       if (ps && !*ps && op_const_sv(block, cv))
-           CvCONST_on(cv);
-    }
-
   attrs:
     if (attrs) {
        /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
@@ -8780,6 +8814,24 @@ Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
     return cv;
 }
 
+/*
+=for apidoc U||newXS
+
+Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
+
+=cut
+*/
+
+CV *
+Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
+{
+    PERL_ARGS_ASSERT_NEWXS;
+    return newXS_len_flags(
+       name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
+    );
+}
+
 CV *
 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
                 const char *const filename, const char *const proto,
@@ -8792,6 +8844,15 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
 }
 
 CV *
+Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
+{
+    PERL_ARGS_ASSERT_NEWXS_DEFFILE;
+    return newXS_len_flags(
+       name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
+    );
+}
+
+CV *
 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
                           XSUBADDR_t subaddr, const char *const filename,
                           const char *const proto, SV **const_svp,
@@ -8801,17 +8862,16 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
     bool interleave = FALSE;
 
     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
-
+    if (!subaddr)
+       Perl_croak_nocontext("panic: no address for '%s' in '%s'",
+           name, filename ? filename : PL_xsubfilename);
     {
         GV * const gv = gv_fetchpvn(
                            name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
                            name ? len : PL_curstash ? sizeof("__ANON__") - 1:
                                sizeof("__ANON__::__ANON__") - 1,
                            GV_ADDMULTI | flags, SVt_PVCV);
-    
-        if (!subaddr)
-            Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
-    
+
         if ((cv = (name ? GvCV(gv) : NULL))) {
             if (GvCVGEN(gv)) {
                 /* just a cached method */
@@ -8846,13 +8906,22 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
                     gv_method_changed(gv); /* newXS */
             }
         }
-        if (!name)
-            CvANON_on(cv);
+
         CvGV_set(cv, gv);
-        (void)gv_fetchfile(filename);
-        CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
-                                    an external constant string */
-        assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+        if(filename) {
+            (void)gv_fetchfile(filename);
+            assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+            if (flags & XS_DYNAMIC_FILENAME) {
+                CvDYNFILE_on(cv);
+                CvFILE(cv) = savepv(filename);
+            } else {
+            /* NOTE: not copied, as it is expected to be an external constant string */
+                CvFILE(cv) = (char *)filename;
+            }
+        } else {
+            assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
+            CvFILE(cv) = (char*)PL_xsubfilename;
+        }
         CvISXSUB_on(cv);
         CvXSUB(cv) = subaddr;
 #ifndef PERL_IMPLICIT_CONTEXT
@@ -8860,15 +8929,14 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
 #else
         PoisonPADLIST(cv);
 #endif
-    
+
         if (name)
             process_special_blocks(0, name, gv, cv);
-    }
+        else
+            CvANON_on(cv);
+    } /* <- not a conditional branch */
+
 
-    if (flags & XS_DYNAMIC_FILENAME) {
-       CvFILE(cv) = savepv(filename);
-       CvDYNFILE_on(cv);
-    }
     sv_setpv(MUTABLE_SV(cv), proto);
     if (interleave) LEAVE;
     return cv;
@@ -8897,24 +8965,6 @@ Perl_newSTUB(pTHX_ GV *gv, bool fake)
     return cv;
 }
 
-/*
-=for apidoc U||newXS
-
-Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
-static storage, as it is used directly as CvFILE(), without a copy being made.
-
-=cut
-*/
-
-CV *
-Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
-{
-    PERL_ARGS_ASSERT_NEWXS;
-    return newXS_len_flags(
-       name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
-    );
-}
-
 void
 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
 {
@@ -9401,7 +9451,7 @@ Perl_ck_eval(pTHX_ OP *o)
        }
        else {
            scalar((OP*)kid);
-           PL_cv_has_eval = 1;
+           S_set_haseval(aTHX);
        }
     }
     else {
@@ -10129,14 +10179,11 @@ Perl_ck_smartmatch(pTHX_ OP *o)
 }
 
 
-OP *
-Perl_ck_sassign(pTHX_ OP *o)
+static OP *
+S_maybe_targlex(pTHX_ OP *o)
 {
     dVAR;
     OP * const kid = cLISTOPo->op_first;
-
-    PERL_ARGS_ASSERT_CK_SASSIGN;
-
     /* has a disposable target? */
     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
        && !(kid->op_flags & OPf_STACKED)
@@ -10148,38 +10195,48 @@ Perl_ck_sassign(pTHX_ OP *o)
 
        /* Can just relocate the target. */
        if (kkid && kkid->op_type == OP_PADSV
-           && !(kkid->op_private & OPpLVAL_INTRO))
+           && (!(kkid->op_private & OPpLVAL_INTRO)
+              || kkid->op_private & OPpPAD_STATE))
        {
            kid->op_targ = kkid->op_targ;
            kkid->op_targ = 0;
            /* Now we do not need PADSV and SASSIGN.
-             * first replace the PADSV with OP_SIBLING(o), then
-             * detach kid and OP_SIBLING(o) from o */
-            op_sibling_splice(o, kid, 1, OP_SIBLING(o));
-            op_sibling_splice(o, NULL, -1, NULL);
+            * Detach kid and free the rest. */
+           op_sibling_splice(o, NULL, 1, NULL);
            op_free(o);
-           op_free(kkid);
            kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
            return kid;
        }
     }
+    return o;
+}
+
+OP *
+Perl_ck_sassign(pTHX_ OP *o)
+{
+    dVAR;
+    OP * const kid = cLISTOPo->op_first;
+
+    PERL_ARGS_ASSERT_CK_SASSIGN;
+
     if (OP_HAS_SIBLING(kid)) {
        OP *kkid = OP_SIBLING(kid);
-       /* For state variable assignment, kkid is a list op whose op_last
-          is a padsv. */
+       /* For state variable assignment with attributes, kkid is a list op
+          whose op_last is a padsv. */
        if ((kkid->op_type == OP_PADSV ||
             (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
              (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
             )
            )
-               && (kkid->op_private & OPpLVAL_INTRO)
-               && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
+               && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
+                   == (OPpLVAL_INTRO|OPpPAD_STATE)) {
            const PADOFFSET target = kkid->op_targ;
            OP *const other = newOP(OP_PADSV,
                                    kkid->op_flags
                                    | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
            OP *const first = newOP(OP_NULL, 0);
-           OP *const nullop = newCONDOP(0, first, o, other);
+           OP *const nullop =
+               newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
            OP *const condop = first->op_next;
 
             CHANGE_TYPE(condop, OP_ONCE);
@@ -10195,7 +10252,7 @@ Perl_ck_sassign(pTHX_ OP *o)
            return nullop;
        }
     }
-    return o;
+    return S_maybe_targlex(aTHX_ o);
 }
 
 OP *
@@ -12708,7 +12765,9 @@ Perl_rpeep(pTHX_ OP *o)
            break;
 
        case OP_RUNCV:
-           if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
+           if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
+            && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
+           {
                SV *sv;
                if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
                else {
@@ -12769,6 +12828,14 @@ Perl_rpeep(pTHX_ OP *o)
            /* We do the common-vars check here, rather than in newASSIGNOP
               (as formerly), so that all lexical vars that get aliased are
               marked as such before we do the check.  */
+           /* There can’t be common vars if the lhs is a stub.  */
+           if (OP_SIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
+                   == cLISTOPx(cBINOPo->op_last)->op_last
+            && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
+           {
+               o->op_private &=~ OPpASSIGN_COMMON;
+               break;
+           }
            if (o->op_private & OPpASSIGN_COMMON) {
                 /* See the comment before S_aassign_common_vars concerning
                    PL_generation sorcery.  */