X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/cc8773c013ccdaec9cb8d2c57d85a70c368e102f..112a1457c05eac6b69395fa04d5d1fdca4a73702:/op.c

diff --git a/op.c b/op.c
index 1bd3498..5ca1823 100644
--- a/op.c
+++ b/op.c
@@ -1,3 +1,4 @@
+#line 2 "op.c"
 /*    op.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
@@ -102,8 +103,9 @@ recursive, but it's recursive on basic blocks, not on tree nodes.
 #include "perl.h"
 #include "keywords.h"
 
-#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
-#define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
+#define CALL_PEEP(o) PL_peepp(aTHX_ o)
+#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
+#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 
 #if defined(PL_OP_SLAB_ALLOC)
 
@@ -304,7 +306,7 @@ Perl_Slab_Free(pTHX_ void *op)
      ? ( op_free((OP*)o),					\
 	 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),	\
 	 (OP*)0 )						\
-     : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
+     : PL_check[type](aTHX_ (OP*)o))
 
 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 
@@ -371,7 +373,7 @@ S_no_bareword_allowed(pTHX_ const OP *o)
 /* "register" allocation */
 
 PADOFFSET
-Perl_allocmy(pTHX_ const char *const name)
+Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
 {
     dVAR;
     PADOFFSET off;
@@ -379,38 +381,43 @@ Perl_allocmy(pTHX_ const char *const name)
 
     PERL_ARGS_ASSERT_ALLOCMY;
 
+    if (flags)
+	Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
+		   (UV)flags);
+
+    /* Until we're using the length for real, cross check that we're being
+       told the truth.  */
+    assert(strlen(name) == len);
+
     /* complain about "my $<special_var>" etc etc */
-    if (*name &&
+    if (len &&
 	!(is_our ||
 	  isALPHA(name[1]) ||
 	  (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
-	  (name[1] == '_' && (*name == '$' || name[2]))))
+	  (name[1] == '_' && (*name == '$' || len > 2))))
     {
 	/* name[2] is true if strlen(name) > 2  */
 	if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
-	    yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
-			      name[0], toCTRL(name[1]), name + 2,
+	    yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
+			      name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
 			      PL_parser->in_my == KEY_state ? "state" : "my"));
 	} else {
-	    yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
+	    yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
 			      PL_parser->in_my == KEY_state ? "state" : "my"));
 	}
     }
 
-    /* check for duplicate declaration */
-    pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
-
     /* allocate a spare slot and store the name in that slot */
 
-    off = pad_add_name(name,
+    off = pad_add_name(name, len,
+		       is_our ? padadd_OUR :
+		       PL_parser->in_my == KEY_state ? padadd_STATE : 0,
 		    PL_parser->in_my_stash,
 		    (is_our
 		        /* $_ is always in main::, even with our */
 			? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 			: NULL
-		    ),
-		    0, /*  not fake */
-		    PL_parser->in_my == KEY_state
+		    )
     );
     /* anon sub prototypes contains state vars should always be cloned,
      * otherwise the state var would be shared between anon subs */
@@ -556,6 +563,7 @@ Perl_op_clear(pTHX_ OP *o)
 	    o->op_targ = 0;
 	    goto retry;
 	}
+    case OP_ENTERTRY:
     case OP_ENTEREVAL:	/* Was holding hints. */
 	o->op_targ = 0;
 	break;
@@ -569,6 +577,29 @@ Perl_op_clear(pTHX_ OP *o)
     case OP_AELEMFAST:
 	if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
 	    /* not an OP_PADAV replacement */
+	    GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
+#ifdef USE_ITHREADS
+			&& PL_curpad
+#endif
+			? cGVOPo_gv : NULL;
+	    /* It's possible during global destruction that the GV is freed
+	       before the optree. Whilst the SvREFCNT_inc is happy to bump from
+	       0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
+	       will trigger an assertion failure, because the entry to sv_clear
+	       checks that the scalar is not already freed.  A check of for
+	       !SvIS_FREED(gv) turns out to be invalid, because during global
+	       destruction the reference count can be forced down to zero
+	       (with SVf_BREAK set).  In which case raising to 1 and then
+	       dropping to 0 triggers cleanup before it should happen.  I
+	       *think* that this might actually be a general, systematic,
+	       weakness of the whole idea of SVf_BREAK, in that code *is*
+	       allowed to raise and lower references during global destruction,
+	       so any *valid* code that happens to do this during global
+	       destruction might well trigger premature cleanup.  */
+	    bool still_valid = gv && SvREFCNT(gv);
+
+	    if (still_valid)
+		SvREFCNT_inc_simple_void(gv);
 #ifdef USE_ITHREADS
 	    if (cPADOPo->op_padix > 0) {
 		/* No GvIN_PAD_off(cGVOPo_gv) here, because other references
@@ -580,6 +611,12 @@ Perl_op_clear(pTHX_ OP *o)
 	    SvREFCNT_dec(cSVOPo->op_sv);
 	    cSVOPo->op_sv = NULL;
 #endif
+	    if (still_valid) {
+		int try_downgrade = SvREFCNT(gv) == 2;
+		SvREFCNT_dec(gv);
+		if (try_downgrade)
+		    gv_try_downgrade(gv);
+	    }
 	}
 	break;
     case OP_METHOD_NAMED:
@@ -872,12 +909,8 @@ Perl_scalar(pTHX_ OP *o)
 	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 	    scalar(kid);
 	break;
-    case OP_SPLIT:
-	if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
-	    if (!kPMOP->op_pmreplrootu.op_pmreplroot)
-		deprecate_old("implicit split to @_");
-	}
 	/* FALL THROUGH */
+    case OP_SPLIT:
     case OP_MATCH:
     case OP_QR:
     case OP_SUBST:
@@ -892,28 +925,30 @@ Perl_scalar(pTHX_ OP *o)
     case OP_LEAVETRY:
 	kid = cLISTOPo->op_first;
 	scalar(kid);
-	while ((kid = kid->op_sibling)) {
-	    if (kid->op_sibling)
-		scalarvoid(kid);
-	    else
+	kid = kid->op_sibling;
+    do_kids:
+	while (kid) {
+	    OP *sib = kid->op_sibling;
+	    if (sib && kid->op_type != OP_LEAVEWHEN) {
+		if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
+		    scalar(kid);
+		    scalarvoid(sib);
+		    break;
+		} else
+		    scalarvoid(kid);
+	    } else
 		scalar(kid);
+	    kid = sib;
 	}
 	PL_curcop = &PL_compiling;
 	break;
     case OP_SCOPE:
     case OP_LINESEQ:
     case OP_LIST:
-	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
-	    if (kid->op_sibling)
-		scalarvoid(kid);
-	    else
-		scalar(kid);
-	}
-	PL_curcop = &PL_compiling;
-	break;
+	kid = cLISTOPo->op_first;
+	goto do_kids;
     case OP_SORT:
-	if (ckWARN(WARN_VOID))
-	    Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
+	Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 	break;
     }
     return o;
@@ -955,7 +990,7 @@ Perl_scalarvoid(pTHX_ OP *o)
     want = o->op_flags & OPf_WANT;
     if ((want && want != OPf_WANT_SCALAR)
 	 || (PL_parser && PL_parser->error_count)
-	 || o->op_type == OP_RETURN)
+	 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
     {
 	return o;
     }
@@ -1056,6 +1091,17 @@ Perl_scalarvoid(pTHX_ OP *o)
 	    useless = OP_DESC(o);
 	break;
 
+    case OP_SPLIT:
+	kid = cLISTOPo->op_first;
+	if (kid && kid->op_type == OP_PUSHRE
+#ifdef USE_ITHREADS
+		&& !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
+#else
+		&& !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
+#endif
+	    useless = OP_DESC(o);
+	break;
+
     case OP_NOT:
        kid = cUNOPo->op_first;
        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
@@ -1065,6 +1111,11 @@ Perl_scalarvoid(pTHX_ OP *o)
        useless = "negative pattern binding (!~)";
        break;
 
+    case OP_SUBST:
+	if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
+	    useless = "Non-destructive substitution (s///r)";
+	break;
+
     case OP_RV2GV:
     case OP_RV2SV:
     case OP_RV2AV:
@@ -1185,21 +1236,11 @@ Perl_scalarvoid(pTHX_ OP *o)
     case OP_ENTEREVAL:
 	scalarkids(o);
 	break;
-    case OP_REQUIRE:
-	/* all requires must return a boolean value */
-	o->op_flags &= ~OPf_WANT;
-	/* FALL THROUGH */
     case OP_SCALAR:
 	return scalar(o);
-    case OP_SPLIT:
-	if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
-	    if (!kPMOP->op_pmreplrootu.op_pmreplroot)
-		deprecate_old("implicit split to @_");
-	}
-	break;
     }
-    if (useless && ckWARN(WARN_VOID))
-	Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
+    if (useless)
+	Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
     return o;
 }
 
@@ -1265,28 +1306,27 @@ Perl_list(pTHX_ OP *o)
     case OP_LEAVETRY:
 	kid = cLISTOPo->op_first;
 	list(kid);
-	while ((kid = kid->op_sibling)) {
-	    if (kid->op_sibling)
-		scalarvoid(kid);
-	    else
+	kid = kid->op_sibling;
+    do_kids:
+	while (kid) {
+	    OP *sib = kid->op_sibling;
+	    if (sib && kid->op_type != OP_LEAVEWHEN) {
+		if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
+		    list(kid);
+		    scalarvoid(sib);
+		    break;
+		} else
+		    scalarvoid(kid);
+	    } else
 		list(kid);
+	    kid = sib;
 	}
 	PL_curcop = &PL_compiling;
 	break;
     case OP_SCOPE:
     case OP_LINESEQ:
-	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
-	    if (kid->op_sibling)
-		scalarvoid(kid);
-	    else
-		list(kid);
-	}
-	PL_curcop = &PL_compiling;
-	break;
-    case OP_REQUIRE:
-	/* all requires must return a boolean value */
-	o->op_flags &= ~OPf_WANT;
-	return scalar(o);
+	kid = cLISTOPo->op_first;
+	goto do_kids;
     }
     return o;
 }
@@ -1551,12 +1591,17 @@ Perl_mod(pTHX_ OP *o, I32 type)
     case OP_DBSTATE:
        PL_modcount = RETURN_UNLIMITED_NUMBER;
 	break;
+    case OP_AV2ARYLEN:
+	PL_hints |= HINT_BLOCK_SCOPE;
+	if (type == OP_LEAVESUBLV)
+	    o->op_private |= OPpMAYBE_LVSUB;
+	PL_modcount++;
+	break;
     case OP_RV2SV:
 	ref(cUNOPo->op_first, o->op_type);
 	localize = 1;
 	/* FALL THROUGH */
     case OP_GV:
-    case OP_AV2ARYLEN:
 	PL_hints |= HINT_BLOCK_SCOPE;
     case OP_SASSIGN:
     case OP_ANDASSIGN:
@@ -1677,10 +1722,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	case 0:
 	    break;
 	case -1:
-	    if (ckWARN(WARN_SYNTAX)) {
-		Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
-		    "Useless localization of %s", OP_DESC(o));
-	    }
+	    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+			   "Useless localization of %s", OP_DESC(o));
 	}
     }
     else if (type != OP_GREPSTART && type != OP_ENTERSUB
@@ -2188,6 +2231,11 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
 	no_bareword_allowed(right);
     }
 
+    /* !~ doesn't make sense with s///r, so error on it for now */
+    if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
+	type == OP_NOT)
+	yyerror("Using !~ with s///r doesn't make sense");
+
     ismatchop = rtype == OP_MATCH ||
 		rtype == OP_SUBST ||
 		rtype == OP_TRANS;
@@ -2201,7 +2249,9 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
 	right->op_flags |= OPf_STACKED;
 	if (rtype != OP_MATCH &&
             ! (rtype == OP_TRANS &&
-               right->op_private & OPpTRANS_IDENTICAL))
+               right->op_private & OPpTRANS_IDENTICAL) &&
+	    ! (rtype == OP_SUBST &&
+	       (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
 	    newleft = mod(left, rtype);
 	else
 	    newleft = left;
@@ -2256,17 +2306,21 @@ Perl_scope(pTHX_ OP *o)
     }
     return o;
 }
-	
+
 int
 Perl_block_start(pTHX_ int full)
 {
     dVAR;
     const int retval = PL_savestack_ix;
+
     pad_block_start(full);
     SAVEHINTS();
     PL_hints &= ~HINT_BLOCK_SCOPE;
     SAVECOMPILEWARNINGS();
     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+
+    CALL_BLOCK_HOOKS(start, full);
+
     return retval;
 }
 
@@ -2275,20 +2329,45 @@ Perl_block_end(pTHX_ I32 floor, OP *seq)
 {
     dVAR;
     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
-    OP* const retval = scalarseq(seq);
+    OP* retval = scalarseq(seq);
+
+    CALL_BLOCK_HOOKS(pre_end, &retval);
+
     LEAVE_SCOPE(floor);
     CopHINTS_set(&PL_compiling, PL_hints);
     if (needblockscope)
 	PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
     pad_leavemy();
+
+    CALL_BLOCK_HOOKS(post_end, &retval);
+
     return retval;
 }
 
+/*
+=head1 Compile-time scope hooks
+
+=for apidoc Ao||blockhook_register
+
+Register a set of hooks to be called when the Perl lexical scope changes
+at compile time. See L<perlguts/"Compile-time scope hooks">.
+
+=cut
+*/
+
+void
+Perl_blockhook_register(pTHX_ BHK *hk)
+{
+    PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
+
+    Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
+}
+
 STATIC OP *
 S_newDEFSVOP(pTHX)
 {
     dVAR;
-    const PADOFFSET offset = pad_findmy("$_");
+    const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
 	return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
     }
@@ -2590,7 +2669,7 @@ S_gen_constant_list(pTHX_ register OP *o)
     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
     o->op_flags &= ~OPf_REF;	/* treat \(1..2) like an ordinary list */
     o->op_flags |= OPf_PARENS;	/* and flatten \(1..2,3) */
-    o->op_opt = 0;		/* needs to be revisited in peep() */
+    o->op_opt = 0;		/* needs to be revisited in rpeep() */
     curop = ((UNOP*)o)->op_first;
     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
 #ifdef PERL_MAD
@@ -2770,7 +2849,7 @@ Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
     /* faked up qw list? */
     if (slot == '(' &&
 	tm->mad_type == MAD_SV &&
-	SvPVX((const SV *)tm->mad_val)[0] == 'q')
+	SvPVX((SV *)tm->mad_val)[0] == 'q')
 	    slot = 'x';
 
     if (o) {
@@ -2927,7 +3006,7 @@ Perl_newMADsv(pTHX_ char key, SV* sv)
 }
 
 MADPROP *
-Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
+Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
 {
     MADPROP *mp;
     Newxz(mp, 1, MADPROP);
@@ -2972,6 +3051,17 @@ Perl_mad_free(pTHX_ MADPROP* mp)
 
 #endif
 
+/*
+=head1 Optree construction
+
+=for apidoc Am|OP *|newNULLLIST
+
+Constructs, checks, and returns a new C<stub> op, which represents an
+empty list expression.
+
+=cut
+*/
+
 OP *
 Perl_newNULLLIST(pTHX)
 {
@@ -2987,12 +3077,26 @@ S_force_list(pTHX_ OP *o)
     return o;
 }
 
+/*
+=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
+
+Constructs, checks, and returns an op of any list type.  I<type> is
+the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
+C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
+supply up to two ops to be direct children of the list op; they are
+consumed by this function and become part of the constructed op tree.
+
+=cut
+*/
+
 OP *
 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
 {
     dVAR;
     LISTOP *listop;
 
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
+
     NewOp(1101, listop, 1, LISTOP);
 
     listop->op_type = (OPCODE)type;
@@ -3021,11 +3125,28 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
     return CHECKOP(type, listop);
 }
 
+/*
+=for apidoc Am|OP *|newOP|I32 type|I32 flags
+
+Constructs, checks, and returns an op of any base type (any type that
+has no extra fields).  I<type> is the opcode.  I<flags> gives the
+eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
+of C<op_private>.
+
+=cut
+*/
+
 OP *
 Perl_newOP(pTHX_ I32 type, I32 flags)
 {
     dVAR;
     OP *o;
+
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
+	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
+	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
+	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
+
     NewOp(1101, o, 1, OP);
     o->op_type = (OPCODE)type;
     o->op_ppaddr = PL_ppaddr[type];
@@ -3043,12 +3164,34 @@ Perl_newOP(pTHX_ I32 type, I32 flags)
     return CHECKOP(type, o);
 }
 
+/*
+=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
+
+Constructs, checks, and returns an op of any unary type.  I<type> is
+the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
+C<OPf_KIDS> will be set automatically if required, and, shifted up eight
+bits, the eight bits of C<op_private>, except that the bit with value 1
+is automatically set.  I<first> supplies an optional op to be the direct
+child of the unary op; it is consumed by this function and become part
+of the constructed op tree.
+
+=cut
+*/
+
 OP *
 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
 {
     dVAR;
     UNOP *unop;
 
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
+	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
+	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
+	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
+	|| type == OP_SASSIGN
+	|| type == OP_ENTERTRY
+	|| type == OP_NULL );
+
     if (!first)
 	first = newOP(OP_STUB, 0);
     if (PL_opargs[type] & OA_MARK)
@@ -3067,11 +3210,29 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
     return fold_constants((OP *) unop);
 }
 
+/*
+=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
+
+Constructs, checks, and returns an op of any binary type.  I<type>
+is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
+that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
+the eight bits of C<op_private>, except that the bit with value 1 or
+2 is automatically set as required.  I<first> and I<last> supply up to
+two ops to be the direct children of the binary op; they are consumed
+by this function and become part of the constructed op tree.
+
+=cut
+*/
+
 OP *
 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
 {
     dVAR;
     BINOP *binop;
+
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
+	|| type == OP_SASSIGN || type == OP_NULL );
+
     NewOp(1101, binop, 1, BINOP);
 
     if (!first)
@@ -3442,12 +3603,10 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 	}
     }
 
-    if(ckWARN(WARN_MISC)) {
-        if(del && rlen == tlen) {
-            Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
-        } else if(rlen > tlen) {
-            Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
-        } 
+    if(del && rlen == tlen) {
+	Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
+    } else if(rlen > tlen) {
+	Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
     }
 
     if (grows)
@@ -3463,12 +3622,24 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
     return o;
 }
 
+/*
+=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
+
+Constructs, checks, and returns an op of any pattern matching type.
+I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
+and, shifted up eight bits, the eight bits of C<op_private>.
+
+=cut
+*/
+
 OP *
 Perl_newPMOP(pTHX_ I32 type, I32 flags)
 {
     dVAR;
     PMOP *pmop;
 
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
+
     NewOp(1101, pmop, 1, PMOP);
     pmop->op_type = (OPCODE)type;
     pmop->op_ppaddr = PL_ppaddr[type];
@@ -3705,6 +3876,17 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
     return (OP*)pm;
 }
 
+/*
+=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
+
+Constructs, checks, and returns an op of any type that involves an
+embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
+of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
+takes ownership of one reference to it.
+
+=cut
+*/
+
 OP *
 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
 {
@@ -3713,6 +3895,10 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
 
     PERL_ARGS_ASSERT_NEWSVOP;
 
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
+	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
+
     NewOp(1101, svop, 1, SVOP);
     svop->op_type = (OPCODE)type;
     svop->op_ppaddr = PL_ppaddr[type];
@@ -3727,6 +3913,21 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
 }
 
 #ifdef USE_ITHREADS
+
+/*
+=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
+
+Constructs, checks, and returns an op of any type that involves a
+reference to a pad element.  I<type> is the opcode.  I<flags> gives the
+eight bits of C<op_flags>.  A pad slot is automatically allocated, and
+is populated with I<sv>; this function takes ownership of one reference
+to it.
+
+This function only exists if Perl has been compiled to use ithreads.
+
+=cut
+*/
+
 OP *
 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
 {
@@ -3735,6 +3936,10 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
 
     PERL_ARGS_ASSERT_NEWPADOP;
 
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
+	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
+
     NewOp(1101, padop, 1, PADOP);
     padop->op_type = (OPCODE)type;
     padop->op_ppaddr = PL_ppaddr[type];
@@ -3751,7 +3956,20 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
 	padop->op_targ = pad_alloc(type, SVs_PADTMP);
     return CHECKOP(type, padop);
 }
-#endif
+
+#endif /* !USE_ITHREADS */
+
+/*
+=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
+
+Constructs, checks, and returns an op of any type that involves an
+embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
+eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
+reference; calling this function does not transfer ownership of any
+reference to it.
+
+=cut
+*/
 
 OP *
 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
@@ -3768,11 +3986,27 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
 #endif
 }
 
+/*
+=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
+
+Constructs, checks, and returns an op of any type that involves an
+embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
+the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
+must have been allocated using L</PerlMemShared_malloc>; the memory will
+be freed when the op is destroyed.
+
+=cut
+*/
+
 OP *
 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
 {
     dVAR;
     PVOP *pvop;
+
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
+
     NewOp(1101, pvop, 1, PVOP);
     pvop->op_type = (OPCODE)type;
     pvop->op_ppaddr = PL_ppaddr[type];
@@ -3826,6 +4060,18 @@ Perl_package(pTHX_ OP *o)
 #endif
 }
 
+void
+Perl_package_version( pTHX_ OP *v )
+{
+    dVAR;
+    U32 savehints = PL_hints;
+    PERL_ARGS_ASSERT_PACKAGE_VERSION;
+    PL_hints &= ~HINT_STRICT_VARS;
+    sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
+    PL_hints = savehints;
+    op_free(v);
+}
+
 #ifdef PERL_MAD
 OP*
 #else
@@ -4069,6 +4315,22 @@ Perl_dofile(pTHX_ OP *term, I32 force_builtin)
     return doop;
 }
 
+/*
+=head1 Optree construction
+
+=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
+
+Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
+gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
+be set automatically, and, shifted up eight bits, the eight bits of
+C<op_private>, except that the bit with value 1 or 2 is automatically
+set as required.  I<listval> and I<subscript> supply the parameters of
+the slice; they are consumed by this function and become part of the
+constructed op tree.
+
+=cut
+*/
+
 OP *
 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
 {
@@ -4121,6 +4383,29 @@ S_is_list_assignment(pTHX_ register const OP *o)
     return FALSE;
 }
 
+/*
+=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
+
+Constructs, checks, and returns an assignment op.  I<left> and I<right>
+supply the parameters of the assignment; they are consumed by this
+function and become part of the constructed op tree.
+
+If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
+a suitable conditional optree is constructed.  If I<optype> is the opcode
+of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
+performs the binary operation and assigns the result to the left argument.
+Either way, if I<optype> is non-zero then I<flags> has no effect.
+
+If I<optype> is zero, then a plain scalar or list assignment is
+constructed.  Which type of assignment it is is automatically determined.
+I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
+will be set automatically, and, shifted up eight bits, the eight bits
+of C<op_private>, except that the bit with value 1 or 2 is automatically
+set as required.
+
+=cut
+*/
+
 OP *
 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 {
@@ -4153,6 +4438,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 	if (PL_eval_start)
 	    PL_eval_start = 0;
 	else if (left->op_type == OP_CONST) {
+	    deprecate("assignment to $[");
 	    /* FIXME for MAD */
 	    /* Result of assignment is always 1 (or we'd be dead already) */
 	    return newSVOP(OP_CONST, 0, newSViv(1));
@@ -4204,7 +4490,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 		    || left->op_type == OP_PADHV
 		    || left->op_type == OP_PADANY))
 	{
-	    maybe_common_vars = FALSE;
+	    if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
 	    if (left->op_private & OPpPAD_STATE) {
 		/* All single variable list context state assignments, hence
 		   state ($a) = ...
@@ -4368,6 +4654,24 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
     return o;
 }
 
+/*
+=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
+
+Constructs a state op (COP).  The state op is normally a C<nextstate> op,
+but will be a C<dbstate> op if debugging is enabled for currently-compiled
+code.  The state op is populated from L</PL_curcop> (or L</PL_compiling>).
+If I<label> is non-null, it supplies the name of a label to attach to
+the state op; this function takes ownership of the memory pointed at by
+I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
+for the state op.
+
+If I<o> is null, the state op is returned.  Otherwise the state op is
+combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
+is consumed by this function and becomes part of the returned op tree.
+
+=cut
+*/
+
 OP *
 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
 {
@@ -4404,8 +4708,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
 	HINTS_REFCNT_UNLOCK;
     }
     if (label) {
-	cop->cop_hints_hash
-	    = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
+	Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
 						     
 	PL_hints |= HINT_BLOCK_SCOPE;
 	/* It seems that we need to defer freeing this pointer, as other parts
@@ -4445,6 +4748,19 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
 }
 
+/*
+=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
+
+Constructs, checks, and returns a logical (flow control) op.  I<type>
+is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
+that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
+the eight bits of C<op_private>, except that the bit with value 1 is
+automatically set.  I<first> supplies the expression controlling the
+flow, and I<other> supplies the side (alternate) chain of ops; they are
+consumed by this function and become part of the constructed op tree.
+
+=cut
+*/
 
 OP *
 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
@@ -4518,6 +4834,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
     if (type == OP_XOR)		/* Not short circuit, but here by precedence. */
 	return newBINOP(type, flags, scalar(first), scalar(other));
 
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
+
     scalarboolean(first);
     /* optimize AND and OR ops that have NOTs as children */
     if (first->op_type == OP_NOT
@@ -4541,8 +4859,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
     if ((cstop = search_const(first))) {
 	if (cstop->op_private & OPpCONST_STRICT)
 	    no_bareword_allowed(cstop);
-	else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
-		Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
+	else if ((cstop->op_private & OPpCONST_BARE))
+		Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
 	if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
 	    (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
 	    (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
@@ -4572,11 +4890,10 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
 	    if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
 			|| o2->op_type == OP_PADHV)
 		&& o2->op_private & OPpLVAL_INTRO
-		&& !(o2->op_private & OPpPAD_STATE)
-		&& ckWARN(WARN_DEPRECATED))
+		&& !(o2->op_private & OPpPAD_STATE))
 	    {
-		Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
-			    "Deprecated use of my() in false conditional");
+		Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+				 "Deprecated use of my() in false conditional");
 	    }
 
 	    *otherp = NULL;
@@ -4660,6 +4977,20 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
     return o;
 }
 
+/*
+=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
+
+Constructs, checks, and returns a conditional-expression (C<cond_expr>)
+op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
+will be set automatically, and, shifted up eight bits, the eight bits of
+C<op_private>, except that the bit with value 1 is automatically set.
+I<first> supplies the expression selecting between the two branches,
+and I<trueop> and I<falseop> supply the branches; they are consumed by
+this function and become part of the constructed op tree.
+
+=cut
+*/
+
 OP *
 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
 {
@@ -4725,6 +5056,20 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
     return o;
 }
 
+/*
+=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
+
+Constructs and returns a C<range> op, with subordinate C<flip> and
+C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
+C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
+for both the C<flip> and C<range> ops, except that the bit with value
+1 is automatically set.  I<left> and I<right> supply the expressions
+controlling the endpoints of the range; they are consumed by this function
+and become part of the constructed op tree.
+
+=cut
+*/
+
 OP *
 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
 {
@@ -4774,6 +5119,22 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
     return o;
 }
 
+/*
+=for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
+
+Constructs, checks, and returns an op tree expressing a loop.  This is
+only a loop in the control flow through the op tree; it does not have
+the heavyweight loop structure that allows exiting the loop by C<last>
+and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
+top-level op, except that some bits will be set automatically as required.
+I<expr> supplies the expression controlling loop iteration, and I<block>
+supplies the body of the loop; they are consumed by this function and
+become part of the constructed op tree.  I<debuggable> is currently
+unused and should always be 1.
+
+=cut
+*/
+
 OP *
 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
 {
@@ -4788,7 +5149,9 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
     if (expr) {
 	if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
 	    return block;	/* do {} while 0 does once */
-	if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+	if (expr->op_type == OP_READLINE
+	    || expr->op_type == OP_READDIR
+	    || expr->op_type == OP_GLOB
 	    || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
 	    expr = newUNOP(OP_DEFINED, 0,
 		newASSIGNOP(0, newDEFSVOP(), 0, expr) );
@@ -4797,7 +5160,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
 	    const OP * const k2 = k1 ? k1->op_sibling : NULL;
 	    switch (expr->op_type) {
 	      case OP_NULL:
-		if (k2 && k2->op_type == OP_READLINE
+		if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
 		      && (k2->op_flags & OPf_STACKED)
 		      && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
 		    expr = newUNOP(OP_DEFINED, 0, expr);
@@ -4836,6 +5199,31 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
     return o;
 }
 
+/*
+=for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|I32 whileline|OP *expr|OP *block|OP *cont|I32 has_my
+
+Constructs, checks, and returns an op tree expressing a C<while> loop.
+This is a heavyweight loop, with structure that allows exiting the loop
+by C<last> and suchlike.
+
+I<loop> is an optional preconstructed C<enterloop> op to use in the
+loop; if it is null then a suitable op will be constructed automatically.
+I<expr> supplies the loop's controlling expression.  I<block> supplies the
+main body of the loop, and I<cont> optionally supplies a C<continue> block
+that operates as a second half of the body.  All of these optree inputs
+are consumed by this function and become part of the constructed op tree.
+
+I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
+op and, shifted up eight bits, the eight bits of C<op_private> for
+the C<leaveloop> op, except that (in both cases) some bits will be set
+automatically.  I<debuggable> is currently unused and should always be 1.
+I<whileline> is the line number that should be attributed to the loop's
+controlling expression.  I<has_my> can be supplied as true to force the
+loop body to be enclosed in its own scope.
+
+=cut
+*/
+
 OP *
 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
@@ -4850,7 +5238,9 @@ whileline, OP *expr, OP *block, OP *cont, I32 has_my)
     PERL_UNUSED_ARG(debuggable);
 
     if (expr) {
-	if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+	if (expr->op_type == OP_READLINE
+         || expr->op_type == OP_READDIR
+         || expr->op_type == OP_GLOB
 		     || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
 	    expr = newUNOP(OP_DEFINED, 0,
 		newASSIGNOP(0, newDEFSVOP(), 0, expr) );
@@ -4859,7 +5249,7 @@ whileline, OP *expr, OP *block, OP *cont, I32 has_my)
 	    const OP * const k2 = (k1) ? k1->op_sibling : NULL;
 	    switch (expr->op_type) {
 	      case OP_NULL:
-		if (k2 && k2->op_type == OP_READLINE
+		if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
 		      && (k2->op_flags & OPf_STACKED)
 		      && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
 		    expr = newUNOP(OP_DEFINED, 0, expr);
@@ -4937,6 +5327,33 @@ whileline, OP *expr, OP *block, OP *cont, I32 has_my)
     return o;
 }
 
+/*
+=for apidoc Am|OP *|newFOROP|I32 flags|char *label|line_t forline|OP *sv|OP *expr|OP *block|OP *cont
+
+Constructs, checks, and returns an op tree expressing a C<foreach>
+loop (iteration through a list of values).  This is a heavyweight loop,
+with structure that allows exiting the loop by C<last> and suchlike.
+
+I<sv> optionally supplies the variable that will be aliased to each
+item in turn; if null, it defaults to C<$_> (either lexical or global).
+I<expr> supplies the list of values to iterate over.  I<block> supplies
+the main body of the loop, and I<cont> optionally supplies a C<continue>
+block that operates as a second half of the body.  All of these optree
+inputs are consumed by this function and become part of the constructed
+op tree.
+
+I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
+op and, shifted up eight bits, the eight bits of C<op_private> for
+the C<leaveloop> op, except that (in both cases) some bits will be set
+automatically.  I<forline> is the line number that should be attributed
+to the loop's list expression.  If I<label> is non-null, it supplies
+the name of a label to attach to the state op at the start of the loop;
+this function takes ownership of the memory pointed at by I<label>,
+and will free it.
+
+=cut
+*/
+
 OP *
 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
 {
@@ -4989,7 +5406,7 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP
 	}
     }
     else {
-        const PADOFFSET offset = pad_findmy("$_");
+        const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
 	if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
 	    sv = newGVOP(OP_GV, 0, PL_defgv);
 	}
@@ -5063,6 +5480,17 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP
     return newSTATEOP(0, label, wop);
 }
 
+/*
+=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
+
+Constructs, checks, and returns a loop-exiting op (such as C<goto>
+or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
+determining the target of the op; it is consumed by this function and
+become part of the constructed op tree.
+
+=cut
+*/
+
 OP*
 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 {
@@ -5071,6 +5499,8 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 
     PERL_ARGS_ASSERT_NEWLOOPEX;
 
+    assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
+
     if (type != OP_GOTO || label->op_type == OP_CONST) {
 	/* "last()" means "last" */
 	if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
@@ -5200,6 +5630,7 @@ S_looks_like_bool(pTHX_ const OP *o)
 	     && looks_like_bool(cLOGOPo->op_first->op_sibling));
 
 	case OP_NULL:
+	case OP_SCALAR:
 	    return (
 		o->op_flags & OPf_KIDS
 	    && looks_like_bool(cUNOPo->op_first));
@@ -5250,6 +5681,19 @@ S_looks_like_bool(pTHX_ const OP *o)
     }
 }
 
+/*
+=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
+
+Constructs, checks, and returns an op tree expressing a C<given> block.
+I<cond> supplies the expression that will be locally assigned to a lexical
+variable, and I<block> supplies the body of the C<given> construct; they
+are consumed by this function and become part of the constructed op tree.
+I<defsv_off> is the pad offset of the scalar lexical variable that will
+be affected.
+
+=cut
+*/
+
 OP *
 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
 {
@@ -5262,7 +5706,19 @@ Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
 	defsv_off);
 }
 
-/* If cond is null, this is a default {} block */
+/*
+=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
+
+Constructs, checks, and returns an op tree expressing a C<when> block.
+I<cond> supplies the test expression, and I<block> supplies the block
+that will be executed if the test evaluates to true; they are consumed
+by this function and become part of the constructed op tree.  I<cond>
+will be interpreted DWIMically, often as a comparison against C<$_>,
+and may be null to generate a C<default> block.
+
+=cut
+*/
+
 OP *
 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
 {
@@ -5286,6 +5742,8 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block)
 }
 
 /*
+=head1 Embedding Functions
+
 =for apidoc cv_undef
 
 Clear out all the active components of a CV. This can happen either
@@ -5329,7 +5787,7 @@ Perl_cv_undef(pTHX_ CV *cv)
 	LEAVE;
     }
     SvPOK_off(MUTABLE_SV(cv));		/* forget prototype */
-    CvGV(cv) = NULL;
+    CvGV_set(cv, NULL);
 
     pad_undef(cv);
 
@@ -5346,8 +5804,9 @@ Perl_cv_undef(pTHX_ CV *cv)
     if (CvISXSUB(cv) && CvXSUB(cv)) {
 	CvXSUB(cv) = NULL;
     }
-    /* delete all flags except WEAKOUTSIDE */
-    CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
+    /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
+     * ref status of CvOUTSIDE and CvGV */
+    CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
 }
 
 void
@@ -5530,7 +5989,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     dVAR;
     GV *gv;
     const char *ps;
-    STRLEN ps_len;
+    STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
     register CV *cv = NULL;
     SV *const_sv;
     /* If the subroutine has no body, no attributes, and no builtin attributes
@@ -5583,10 +6042,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 					   maximum a prototype before. */
 	if (SvTYPE(gv) > SVt_NULL) {
 	    if (!SvPOK((const SV *)gv)
-		&& !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
-		&& ckWARN_d(WARN_PROTOTYPE))
+		&& !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
 	    {
-		Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
+		Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
 	    }
 	    cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
 	}
@@ -5630,7 +6088,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 		 )&& !attrs) {
 		if (CvFLAGS(PL_compcv)) {
 		    /* might have had built-in attrs applied */
-		    CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
+		    if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
+			Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
+		    CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
 		}
 		/* just a "sub foo;" when &foo is already defined */
 		SAVEFREESV(PL_compcv);
@@ -5692,69 +6152,37 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	PL_compcv = NULL;
 	goto done;
     }
-    if (attrs) {
-	HV *stash;
-	SV *rcv;
-
-	/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
-	 * before we clobber PL_compcv.
-	 */
-	if (cv && (!block
+    if (cv) {				/* must reuse cv if autoloaded */
+	/* transfer PL_compcv to cv */
+	if (block
 #ifdef PERL_MAD
-		    || block->op_type == OP_NULL
+                  && block->op_type != OP_NULL
 #endif
-		    )) {
-	    rcv = MUTABLE_SV(cv);
-	    /* Might have had built-in attributes applied -- propagate them. */
-	    CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
-	    if (CvGV(cv) && GvSTASH(CvGV(cv)))
-		stash = GvSTASH(CvGV(cv));
-	    else if (CvSTASH(cv))
-		stash = CvSTASH(cv);
-	    else
-		stash = PL_curstash;
+	) {
+	    cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
+	    cv_undef(cv);
+	    CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
+	    if (!CvWEAKOUTSIDE(cv))
+		SvREFCNT_dec(CvOUTSIDE(cv));
+	    CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
+	    CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
+	    CvOUTSIDE(PL_compcv) = 0;
+	    CvPADLIST(cv) = CvPADLIST(PL_compcv);
+	    CvPADLIST(PL_compcv) = 0;
+	    /* inner references to PL_compcv must be fixed up ... */
+	    pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
+	    if (PERLDB_INTER)/* Advice debugger on the new sub. */
+	      ++PL_sub_generation;
+	    if (CvSTASH(cv))
+		sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
 	}
 	else {
-	    /* possibly about to re-define existing subr -- ignore old cv */
-	    rcv = MUTABLE_SV(PL_compcv);
-	    if (name && GvSTASH(gv))
-		stash = GvSTASH(gv);
-	    else
-		stash = PL_curstash;
-	}
-	apply_attrs(stash, rcv, attrs, FALSE);
-    }
-    if (cv) {				/* must reuse cv if autoloaded */
-	if (
-#ifdef PERL_MAD
-	    (
-#endif
-	     !block
-#ifdef PERL_MAD
-	     || block->op_type == OP_NULL) && !PL_madskills
-#endif
-	     ) {
-	    /* got here with just attrs -- work done, so bug out */
-	    SAVEFREESV(PL_compcv);
-	    goto done;
+	    /* Might have had built-in attributes applied -- propagate them. */
+	    CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
 	}
-	/* transfer PL_compcv to cv */
-	cv_undef(cv);
-	CvFLAGS(cv) = CvFLAGS(PL_compcv);
-	if (!CvWEAKOUTSIDE(cv))
-	    SvREFCNT_dec(CvOUTSIDE(cv));
-	CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
-	CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
-	CvOUTSIDE(PL_compcv) = 0;
-	CvPADLIST(cv) = CvPADLIST(PL_compcv);
-	CvPADLIST(PL_compcv) = 0;
-	/* inner references to PL_compcv must be fixed up ... */
-	pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
 	/* ... before we throw it away */
 	SvREFCNT_dec(PL_compcv);
 	PL_compcv = cv;
-	if (PERLDB_INTER)/* Advice debugger on the new sub. */
-	  ++PL_sub_generation;
     }
     else {
 	cv = PL_compcv;
@@ -5763,16 +6191,26 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    if (PL_madskills) {
 		if (strEQ(name, "import")) {
 		    PL_formfeed = MUTABLE_SV(cv);
-		    Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
+		    /* diag_listed_as: SKIPME */
+		    Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
 		}
 	    }
 	    GvCVGEN(gv) = 0;
             mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
 	}
     }
-    CvGV(cv) = gv;
-    CvFILE_set_from_cop(cv, PL_curcop);
-    CvSTASH(cv) = PL_curstash;
+    if (!CvGV(cv)) {
+	CvGV_set(cv, gv);
+	CvFILE_set_from_cop(cv, PL_curcop);
+	CvSTASH(cv) = PL_curstash;
+	if (PL_curstash)
+	    Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
+    }
+    if (attrs) {
+	/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
+	HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+	apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
+    }
 
     if (ps)
 	sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
@@ -5844,20 +6282,19 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 
     if (has_name) {
 	if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
-	    SV * const sv = newSV(0);
 	    SV * const tmpstr = sv_newmortal();
 	    GV * const db_postponed = gv_fetchpvs("DB::postponed",
 						  GV_ADDMULTI, SVt_PVHV);
 	    HV *hv;
-
-	    Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
-			   CopFILE(PL_curcop),
-			   (long)PL_subline, (long)CopLINE(PL_curcop));
+	    SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
+					  CopFILE(PL_curcop),
+					  (long)PL_subline,
+					  (long)CopLINE(PL_curcop));
 	    gv_efullname3(tmpstr, gv, NULL);
 	    (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
 		    SvCUR(tmpstr), sv, 0);
 	    hv = GvHVn(db_postponed);
-	    if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
+	    if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
 		CV * const pcv = GvCV(db_postponed);
 		if (pcv) {
 		    dSP;
@@ -5896,7 +6333,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
 	    SAVECOPFILE(&PL_compiling);
 	    SAVECOPLINE(&PL_compiling);
 
-	    DEBUG_B( dump_sub(gv) );
+	    DEBUG_x( dump_sub(gv) );
 	    Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
 	    GvCV(gv) = 0;		/* cv has been hijacked */
 	    call_list(oldscope, PL_beginav);
@@ -5910,7 +6347,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
     } else {
 	if (*name == 'E') {
 	    if strEQ(name, "END") {
-		DEBUG_B( dump_sub(gv) );
+		DEBUG_x( dump_sub(gv) );
 		Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
 	    } else
 		return;
@@ -5923,25 +6360,25 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
 		return;
 	} else if (*name == 'C') {
 	    if (strEQ(name, "CHECK")) {
-		if (PL_main_start && ckWARN(WARN_VOID))
-		    Perl_warner(aTHX_ packWARN(WARN_VOID),
-				"Too late to run CHECK block");
+		if (PL_main_start)
+		    Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+				   "Too late to run CHECK block");
 		Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
 	    }
 	    else
 		return;
 	} else if (*name == 'I') {
 	    if (strEQ(name, "INIT")) {
-		if (PL_main_start && ckWARN(WARN_VOID))
-		    Perl_warner(aTHX_ packWARN(WARN_VOID),
-				"Too late to run INIT block");
+		if (PL_main_start)
+		    Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+				   "Too late to run INIT block");
 		Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
 	    }
 	    else
 		return;
 	} else
 	    return;
-	DEBUG_B( dump_sub(gv) );
+	DEBUG_x( dump_sub(gv) );
 	GvCV(gv) = 0;		/* cv has been hijacked */
     }
 }
@@ -6125,7 +6562,9 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
             mro_method_changed_in(GvSTASH(gv)); /* newXS */
 	}
     }
-    CvGV(cv) = gv;
+    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 */
@@ -6134,8 +6573,6 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
 
     if (name)
 	process_special_blocks(name, gv, cv);
-    else
-	CvANON_on(cv);
 
     return cv;
 }
@@ -6176,7 +6613,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
     }
     cv = PL_compcv;
     GvFORM(gv) = cv;
-    CvGV(cv) = gv;
+    CvGV_set(cv, gv);
     CvFILE_set_from_cop(cv, PL_curcop);
 
 
@@ -6247,8 +6684,7 @@ Perl_oopsAV(pTHX_ OP *o)
 	break;
 
     default:
-	if (ckWARN_d(WARN_INTERNAL))
-	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
 	break;
     }
     return o;
@@ -6276,8 +6712,7 @@ Perl_oopsHV(pTHX_ OP *o)
 	break;
 
     default:
-	if (ckWARN_d(WARN_INTERNAL))
-	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
 	break;
     }
     return o;
@@ -6295,10 +6730,9 @@ Perl_newAVREF(pTHX_ OP *o)
 	o->op_ppaddr = PL_ppaddr[OP_PADAV];
 	return o;
     }
-    else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
-		&& ckWARN(WARN_DEPRECATED)) {
-	Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
-		"Using an array as a reference is deprecated");
+    else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+		       "Using an array as a reference is deprecated");
     }
     return newUNOP(OP_RV2AV, 0, scalar(o));
 }
@@ -6323,10 +6757,9 @@ Perl_newHVREF(pTHX_ OP *o)
 	o->op_ppaddr = PL_ppaddr[OP_PADHV];
 	return o;
     }
-    else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
-		&& ckWARN(WARN_DEPRECATED)) {
-	Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
-		"Using a hash as a reference is deprecated");
+    else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+		       "Using a hash as a reference is deprecated");
     }
     return newUNOP(OP_RV2HV, 0, scalar(o));
 }
@@ -6393,12 +6826,11 @@ Perl_ck_bitop(pTHX_ OP *o)
 		(left->op_flags & OPf_PARENS) == 0) ||
 	    (OP_IS_NUMCOMPARE(right->op_type) &&
 		(right->op_flags & OPf_PARENS) == 0))
-	    if (ckWARN(WARN_PRECEDENCE))
-		Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
-			"Possible precedence problem on bitwise %c operator",
-			o->op_type == OP_BIT_OR ? '|'
-			    : o->op_type == OP_BIT_AND ? '&' : '^'
-			);
+	    Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
+			   "Possible precedence problem on bitwise %c operator",
+			   o->op_type == OP_BIT_OR ? '|'
+			   : o->op_type == OP_BIT_AND ? '&' : '^'
+			   );
     }
     return o;
 }
@@ -6549,8 +6981,6 @@ Perl_ck_eval(pTHX_ OP *o)
 	    /* establish postfix order */
 	    enter->op_next = (OP*)enter;
 
-	    CHECKOP(OP_ENTERTRY, enter);
-
 	    o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
 	    o->op_type = OP_LEAVETRY;
 	    o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
@@ -6690,17 +7120,6 @@ Perl_ck_rvconst(pTHX_ register OP *o)
 		Perl_croak(aTHX_ "Constant is not %s reference", badtype);
 	    return o;
 	}
-	else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
-		(PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
-	    /* If this is an access to a stash, disable "strict refs", because
-	     * stashes aren't auto-vivified at compile-time (unless we store
-	     * symbols in them), and we don't want to produce a run-time
-	     * stricture error when auto-vivifying the stash. */
-	    const char *s = SvPV_nolen(kidsv);
-	    const STRLEN l = SvCUR(kidsv);
-	    if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
-		o->op_private &= ~HINT_STRICT_REFS;
-	}
 	if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
 	    const char *badthing;
 	    switch (o->op_type) {
@@ -6869,20 +7288,19 @@ Perl_ck_fun(pTHX_ OP *o)
 		break;
 	    case OA_AVREF:
 		if ((type == OP_PUSH || type == OP_UNSHIFT)
-		    && !kid->op_sibling && ckWARN(WARN_SYNTAX))
-		    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
-			"Useless use of %s with no values",
-			PL_op_desc[type]);
+		    && !kid->op_sibling)
+		    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+				   "Useless use of %s with no values",
+				   PL_op_desc[type]);
 
 		if (kid->op_type == OP_CONST &&
 		    (kid->op_private & OPpCONST_BARE))
 		{
 		    OP * const newop = newAVREF(newGVOP(OP_GV, 0,
 			gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
-		    if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
-			Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-			    "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
-			    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
+		    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+				   "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
+				   SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
 #ifdef PERL_MAD
 		    op_getmad(kid,newop,'K');
 #else
@@ -6902,10 +7320,9 @@ Perl_ck_fun(pTHX_ OP *o)
 		{
 		    OP * const newop = newHVREF(newGVOP(OP_GV, 0,
 			gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
-		    if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
-			Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-			    "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
-			    SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
+		    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+				   "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
+				   SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
 #ifdef PERL_MAD
 		    op_getmad(kid,newop,'K');
 #else
@@ -7112,11 +7529,12 @@ Perl_ck_glob(pTHX_ OP *o)
 	ENTER;
 	Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
 		newSVpvs("File::Glob"), NULL, NULL, NULL);
-	gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
-	glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
-	GvCV(gv) = GvCV(glob_gv);
-	SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
-	GvIMPORTED_CV_on(gv);
+	if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
+	    gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
+	    GvCV(gv) = GvCV(glob_gv);
+	    SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
+	    GvIMPORTED_CV_on(gv);
+	}
 	LEAVE;
     }
 #endif /* PERL_EXTERNAL_GLOB */
@@ -7161,10 +7579,10 @@ Perl_ck_grep(pTHX_ OP *o)
     if (o->op_flags & OPf_STACKED) {
 	OP* k;
 	o = ck_sort(o);
-        kid = cLISTOPo->op_first->op_sibling;
-	if (!cUNOPx(kid)->op_next)
-	    Perl_croak(aTHX_ "panic: ck_grep");
-	for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
+        kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
+	if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
+	    return no_fh_allowed(o);
+	for (k = kid; k; k = k->op_next) {
 	    kid = k;
 	}
 	NewOp(1101, gwop, 1, LOGOP);
@@ -7192,7 +7610,7 @@ Perl_ck_grep(pTHX_ OP *o)
     gwop->op_flags |= OPf_KIDS;
     gwop->op_other = LINKLIST(kid);
     kid->op_next = (OP*)gwop;
-    offset = pad_findmy("$_");
+    offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
 	o->op_private = gwop->op_private = 0;
 	gwop->op_targ = pad_alloc(type, SVs_PADTMP);
@@ -7241,7 +7659,7 @@ Perl_ck_defined(pTHX_ OP *o)		/* 19990527 MJD */
 {
     PERL_ARGS_ASSERT_CK_DEFINED;
 
-    if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
+    if ((o->op_flags & OPf_KIDS)) {
 	switch (cUNOPo->op_first->op_type) {
 	case OP_RV2AV:
 	    /* This is needed for
@@ -7251,22 +7669,17 @@ Perl_ck_defined(pTHX_ OP *o)		/* 19990527 MJD */
 	    break;                      /* Globals via GV can be undef */
 	case OP_PADAV:
 	case OP_AASSIGN:		/* Is this a good idea? */
-	    Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-			"defined(@array) is deprecated");
-	    Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-			"\t(Maybe you should just omit the defined()?)\n");
+	    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+			   "defined(@array) is deprecated");
+	    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+			   "\t(Maybe you should just omit the defined()?)\n");
 	break;
 	case OP_RV2HV:
-	    /* This is needed for
-	       if (defined %stash::)
-	       to work.   Do not break Tk.
-	       */
-	    break;                      /* Globals via GV can be undef */
 	case OP_PADHV:
-	    Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-			"defined(%%hash) is deprecated");
-	    Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-			"\t(Maybe you should just omit the defined()?)\n");
+	    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+			   "defined(%%hash) is deprecated");
+	    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+			   "\t(Maybe you should just omit the defined()?)\n");
 	    break;
 	default:
 	    /* no warning */
@@ -7437,7 +7850,7 @@ Perl_ck_match(pTHX_ OP *o)
     PERL_ARGS_ASSERT_CK_MATCH;
 
     if (o->op_type != OP_QR && PL_compcv) {
-	const PADOFFSET offset = pad_findmy("$_");
+	const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
 	if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
 	    o->op_targ = offset;
 	    o->op_private |= OPpTARGET_MY;
@@ -7636,7 +8049,7 @@ Perl_ck_require(pTHX_ OP *o)
 	return newop;
     }
 
-    return ck_fun(o);
+    return scalar(ck_fun(o));
 }
 
 OP *
@@ -7703,19 +8116,20 @@ Perl_ck_shift(pTHX_ OP *o)
 
     if (!(o->op_flags & OPf_KIDS)) {
 	OP *argop;
-	/* FIXME - this can be refactored to reduce code in #ifdefs  */
+
+	if (!CvUNIQUE(PL_compcv)) {
+	    o->op_flags |= OPf_SPECIAL;
+	    return o;
+	}
+
+	argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
 #ifdef PERL_MAD
 	OP * const oldo = o;
-#else
-	op_free(o);
-#endif
-	argop = newUNOP(OP_RV2AV, 0,
-	    scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
-#ifdef PERL_MAD
 	o = newUNOP(type, 0, scalar(argop));
 	op_getmad(oldo,o,'O');
 	return o;
 #else
+	op_free(o);
 	return newUNOP(type, 0, scalar(argop));
 #endif
     }
@@ -7914,9 +8328,9 @@ Perl_ck_split(pTHX_ OP *o)
     kid->op_type = OP_PUSHRE;
     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
     scalar(kid);
-    if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
-      Perl_warner(aTHX_ packWARN(WARN_REGEXP),
-                  "Use of /g modifier is meaningless in split");
+    if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
+      Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
+		     "Use of /g modifier is meaningless in split");
     }
 
     if (!kid->op_sibling)
@@ -7981,22 +8395,29 @@ Perl_ck_subr(pTHX_ OP *o)
     o->op_private |= OPpENTERSUB_HASTARG;
     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
     if (cvop->op_type == OP_RV2CV) {
-	SVOP* tmpop;
 	o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
 	op_null(cvop);		/* disable rv2cv */
-	tmpop = (SVOP*)((UNOP*)cvop)->op_first;
-	if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
-	    GV *gv = cGVOPx_gv(tmpop);
-	    cv = GvCVu(gv);
-	    if (!cv)
-		tmpop->op_private |= OPpEARLY_CV;
-	    else {
-		if (SvPOK(cv)) {
-		    STRLEN len;
-		    namegv = CvANON(cv) ? gv : CvGV(cv);
-		    proto = SvPV(MUTABLE_SV(cv), len);
-		    proto_end = proto + len;
-		}
+	if (!(o->op_private & OPpENTERSUB_AMPER)) {
+	    SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
+	    GV *gv = NULL;
+	    switch (tmpop->op_type) {
+		case OP_GV: {
+		    gv = cGVOPx_gv(tmpop);
+		    cv = GvCVu(gv);
+		    if (!cv)
+			tmpop->op_private |= OPpEARLY_CV;
+		} break;
+		case OP_CONST: {
+		    SV *sv = cSVOPx_sv(tmpop);
+		    if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
+			cv = (CV*)SvRV(sv);
+		} break;
+	    }
+	    if (cv && SvPOK(cv)) {
+		STRLEN len;
+		namegv = gv && CvANON(cv) ? gv : CvGV(cv);
+		proto = SvPV(MUTABLE_SV(cv), len);
+		proto_end = proto + len;
 	    }
 	}
     }
@@ -8296,31 +8717,133 @@ OP *
 Perl_ck_each(pTHX_ OP *o)
 {
     dVAR;
-    OP *kid = cLISTOPo->op_first;
+    OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
 
     PERL_ARGS_ASSERT_CK_EACH;
 
-    if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
-	const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
-	    : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
-	o->op_type = new_type;
-	o->op_ppaddr = PL_ppaddr[new_type];
-    }
-    else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
-	       || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
-	       )) {
-	bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
-	return o;
+    if (kid) {
+	if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
+	    const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
+		: o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
+	    o->op_type = new_type;
+	    o->op_ppaddr = PL_ppaddr[new_type];
+	}
+	else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
+		    || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
+		  )) {
+	    bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
+	    return o;
+	}
     }
     return ck_fun(o);
 }
 
+/* caller is supposed to assign the return to the 
+   container of the rep_op var */
+STATIC OP *
+S_opt_scalarhv(pTHX_ OP *rep_op) {
+    dVAR;
+    UNOP *unop;
+
+    PERL_ARGS_ASSERT_OPT_SCALARHV;
+
+    NewOp(1101, unop, 1, UNOP);
+    unop->op_type = (OPCODE)OP_BOOLKEYS;
+    unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
+    unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
+    unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
+    unop->op_first = rep_op;
+    unop->op_next = rep_op->op_next;
+    rep_op->op_next = (OP*)unop;
+    rep_op->op_flags|=(OPf_REF | OPf_MOD);
+    unop->op_sibling = rep_op->op_sibling;
+    rep_op->op_sibling = NULL;
+    /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
+    if (rep_op->op_type == OP_PADHV) { 
+        rep_op->op_flags &= ~OPf_WANT_SCALAR;
+        rep_op->op_flags |= OPf_WANT_LIST;
+    }
+    return (OP*)unop;
+}                        
+
+/* Checks if o acts as an in-place operator on an array. oright points to the
+ * beginning of the right-hand side. Returns the left-hand side of the
+ * assignment if o acts in-place, or NULL otherwise. */
+
+STATIC OP *
+S_is_inplace_av(pTHX_ OP *o, OP *oright) {
+    OP *o2;
+    OP *oleft = NULL;
+
+    PERL_ARGS_ASSERT_IS_INPLACE_AV;
+
+    if (!oright ||
+	(oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
+	|| oright->op_next != o
+	|| (oright->op_private & OPpLVAL_INTRO)
+    )
+	return NULL;
+
+    /* o2 follows the chain of op_nexts through the LHS of the
+     * assign (if any) to the aassign op itself */
+    o2 = o->op_next;
+    if (!o2 || o2->op_type != OP_NULL)
+	return NULL;
+    o2 = o2->op_next;
+    if (!o2 || o2->op_type != OP_PUSHMARK)
+	return NULL;
+    o2 = o2->op_next;
+    if (o2 && o2->op_type == OP_GV)
+	o2 = o2->op_next;
+    if (!o2
+	|| (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
+	|| (o2->op_private & OPpLVAL_INTRO)
+    )
+	return NULL;
+    oleft = o2;
+    o2 = o2->op_next;
+    if (!o2 || o2->op_type != OP_NULL)
+	return NULL;
+    o2 = o2->op_next;
+    if (!o2 || o2->op_type != OP_AASSIGN
+	    || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
+	return NULL;
+
+    /* check that the sort is the first arg on RHS of assign */
+
+    o2 = cUNOPx(o2)->op_first;
+    if (!o2 || o2->op_type != OP_NULL)
+	return NULL;
+    o2 = cUNOPx(o2)->op_first;
+    if (!o2 || o2->op_type != OP_PUSHMARK)
+	return NULL;
+    if (o2->op_sibling != o)
+	return NULL;
+
+    /* check the array is the same on both sides */
+    if (oleft->op_type == OP_RV2AV) {
+	if (oright->op_type != OP_RV2AV
+	    || !cUNOPx(oright)->op_first
+	    || cUNOPx(oright)->op_first->op_type != OP_GV
+	    || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
+	       cGVOPx_gv(cUNOPx(oright)->op_first)
+	)
+	    return NULL;
+    }
+    else if (oright->op_type != OP_PADAV
+	|| oright->op_targ != oleft->op_targ
+    )
+	return NULL;
+
+    return oleft;
+}
+
 /* A peephole optimizer.  We visit the ops in the order they're to execute.
  * See the comments at the top of this file for more details about when
  * peep() is called */
 
 void
-Perl_peep(pTHX_ register OP *o)
+Perl_rpeep(pTHX_ register OP *o)
 {
     dVAR;
     register OP* oldop = NULL;
@@ -8338,10 +8861,62 @@ Perl_peep(pTHX_ register OP *o)
 	o->op_opt = 1;
 	PL_op = o;
 	switch (o->op_type) {
-	case OP_NEXTSTATE:
 	case OP_DBSTATE:
 	    PL_curcop = ((COP*)o);		/* for warnings */
 	    break;
+	case OP_NEXTSTATE:
+	    PL_curcop = ((COP*)o);		/* for warnings */
+
+	    /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
+	       to carry two labels. For now, take the easier option, and skip
+	       this optimisation if the first NEXTSTATE has a label.  */
+	    if (!CopLABEL((COP*)o)) {
+		OP *nextop = o->op_next;
+		while (nextop && nextop->op_type == OP_NULL)
+		    nextop = nextop->op_next;
+
+		if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
+		    COP *firstcop = (COP *)o;
+		    COP *secondcop = (COP *)nextop;
+		    /* We want the COP pointed to by o (and anything else) to
+		       become the next COP down the line.  */
+		    cop_free(firstcop);
+
+		    firstcop->op_next = secondcop->op_next;
+
+		    /* Now steal all its pointers, and duplicate the other
+		       data.  */
+		    firstcop->cop_line = secondcop->cop_line;
+#ifdef USE_ITHREADS
+		    firstcop->cop_stashpv = secondcop->cop_stashpv;
+		    firstcop->cop_file = secondcop->cop_file;
+#else
+		    firstcop->cop_stash = secondcop->cop_stash;
+		    firstcop->cop_filegv = secondcop->cop_filegv;
+#endif
+		    firstcop->cop_hints = secondcop->cop_hints;
+		    firstcop->cop_seq = secondcop->cop_seq;
+		    firstcop->cop_warnings = secondcop->cop_warnings;
+		    firstcop->cop_hints_hash = secondcop->cop_hints_hash;
+
+#ifdef USE_ITHREADS
+		    secondcop->cop_stashpv = NULL;
+		    secondcop->cop_file = NULL;
+#else
+		    secondcop->cop_stash = NULL;
+		    secondcop->cop_filegv = NULL;
+#endif
+		    secondcop->cop_warnings = NULL;
+		    secondcop->cop_hints_hash = NULL;
+
+		    /* If we use op_null(), and hence leave an ex-COP, some
+		       warnings are misreported. For example, the compile-time
+		       error in 'use strict; no strict refs;'  */
+		    secondcop->op_type = OP_NULL;
+		    secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
+		}
+	    }
+	    break;
 
 	case OP_CONST:
 	    if (cSVOPo->op_private & OPpCONST_STRICT)
@@ -8413,7 +8988,7 @@ Perl_peep(pTHX_ register OP *o)
 		PL_curcop = ((COP*)o);
 	    }
 	    /* XXX: We avoid setting op_seq here to prevent later calls
-	       to peep() from mistakenly concluding that optimisation
+	       to rpeep() from mistakenly concluding that optimisation
 	       has already occurred. This doesn't fix the real problem,
 	       though (See 20010220.007). AMS 20010719 */
 	    /* op_seq functionality is now replaced by op_opt */
@@ -8501,12 +9076,67 @@ Perl_peep(pTHX_ register OP *o)
 	    }
 
 	    break;
+        
+        {
+            OP *fop;
+            OP *sop;
+            
+        case OP_NOT:
+            fop = cUNOP->op_first;
+            sop = NULL;
+            goto stitch_keys;
+            break;
 
-	case OP_MAPWHILE:
-	case OP_GREPWHILE:
-	case OP_AND:
+        case OP_AND:
 	case OP_OR:
 	case OP_DOR:
+            fop = cLOGOP->op_first;
+            sop = fop->op_sibling;
+	    while (cLOGOP->op_other->op_type == OP_NULL)
+		cLOGOP->op_other = cLOGOP->op_other->op_next;
+	    CALL_RPEEP(cLOGOP->op_other);
+          
+          stitch_keys:	    
+	    o->op_opt = 1;
+            if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
+                || ( sop && 
+                     (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
+                    )
+            ){	
+                OP * nop = o;
+                OP * lop = o;
+                if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
+                    while (nop && nop->op_next) {
+                        switch (nop->op_next->op_type) {
+                            case OP_NOT:
+                            case OP_AND:
+                            case OP_OR:
+                            case OP_DOR:
+                                lop = nop = nop->op_next;
+                                break;
+                            case OP_NULL:
+                                nop = nop->op_next;
+                                break;
+                            default:
+                                nop = NULL;
+                                break;
+                        }
+                    }            
+                }
+                if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
+                    if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) 
+                        cLOGOP->op_first = opt_scalarhv(fop);
+                    if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)) 
+                        cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
+                }                                        
+            }                  
+            
+	    
+	    break;
+	}    
+	
+	case OP_MAPWHILE:
+	case OP_GREPWHILE:
 	case OP_ANDASSIGN:
 	case OP_ORASSIGN:
 	case OP_DORASSIGN:
@@ -8515,20 +9145,20 @@ Perl_peep(pTHX_ register OP *o)
 	case OP_ONCE:
 	    while (cLOGOP->op_other->op_type == OP_NULL)
 		cLOGOP->op_other = cLOGOP->op_other->op_next;
-	    peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
+	    CALL_RPEEP(cLOGOP->op_other);
 	    break;
 
 	case OP_ENTERLOOP:
 	case OP_ENTERITER:
 	    while (cLOOP->op_redoop->op_type == OP_NULL)
 		cLOOP->op_redoop = cLOOP->op_redoop->op_next;
-	    peep(cLOOP->op_redoop);
+	    CALL_RPEEP(cLOOP->op_redoop);
 	    while (cLOOP->op_nextop->op_type == OP_NULL)
 		cLOOP->op_nextop = cLOOP->op_nextop->op_next;
-	    peep(cLOOP->op_nextop);
+	    CALL_RPEEP(cLOOP->op_nextop);
 	    while (cLOOP->op_lastop->op_type == OP_NULL)
 		cLOOP->op_lastop = cLOOP->op_lastop->op_next;
-	    peep(cLOOP->op_lastop);
+	    CALL_RPEEP(cLOOP->op_lastop);
 	    break;
 
 	case OP_SUBST:
@@ -8537,7 +9167,7 @@ Perl_peep(pTHX_ register OP *o)
 		   cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
 		cPMOP->op_pmstashstartu.op_pmreplstart
 		    = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
-	    peep(cPMOP->op_pmstashstartu.op_pmreplstart);
+	    CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
 	    break;
 
 	case OP_EXEC:
@@ -8661,6 +9291,20 @@ Perl_peep(pTHX_ register OP *o)
 	    }
 	    break;
 	}
+	case OP_RV2SV:
+	case OP_RV2AV:
+	case OP_RV2HV:
+	    if (oldop
+		 && (  oldop->op_type == OP_AELEM
+		    || oldop->op_type == OP_PADSV
+		    || oldop->op_type == OP_RV2SV
+		    || oldop->op_type == OP_RV2GV
+		    || oldop->op_type == OP_HELEM
+		    )
+	         && (oldop->op_private & OPpDEREF)
+	    ) {
+		o->op_private |= OPpDEREFed;
+	    }
 
 	case OP_SORT: {
 	    /* will point to RV2AV or PADAV op on LHS/RHS of assign */
@@ -8700,62 +9344,8 @@ Perl_peep(pTHX_ register OP *o)
 		oright = cUNOPx(oright)->op_sibling;
 	    }
 
-	    if (!oright ||
-		(oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
-		|| oright->op_next != o
-		|| (oright->op_private & OPpLVAL_INTRO)
-	    )
-		break;
-
-	    /* o2 follows the chain of op_nexts through the LHS of the
-	     * assign (if any) to the aassign op itself */
-	    o2 = o->op_next;
-	    if (!o2 || o2->op_type != OP_NULL)
-		break;
-	    o2 = o2->op_next;
-	    if (!o2 || o2->op_type != OP_PUSHMARK)
-		break;
-	    o2 = o2->op_next;
-	    if (o2 && o2->op_type == OP_GV)
-		o2 = o2->op_next;
-	    if (!o2
-		|| (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
-		|| (o2->op_private & OPpLVAL_INTRO)
-	    )
-		break;
-	    oleft = o2;
-	    o2 = o2->op_next;
-	    if (!o2 || o2->op_type != OP_NULL)
-		break;
-	    o2 = o2->op_next;
-	    if (!o2 || o2->op_type != OP_AASSIGN
-		    || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
-		break;
-
-	    /* check that the sort is the first arg on RHS of assign */
-
-	    o2 = cUNOPx(o2)->op_first;
-	    if (!o2 || o2->op_type != OP_NULL)
-		break;
-	    o2 = cUNOPx(o2)->op_first;
-	    if (!o2 || o2->op_type != OP_PUSHMARK)
-		break;
-	    if (o2->op_sibling != o)
-		break;
-
-	    /* check the array is the same on both sides */
-	    if (oleft->op_type == OP_RV2AV) {
-		if (oright->op_type != OP_RV2AV
-		    || !cUNOPx(oright)->op_first
-		    || cUNOPx(oright)->op_first->op_type != OP_GV
-		    ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
-		       	cGVOPx_gv(cUNOPx(oright)->op_first)
-		)
-		    break;
-	    }
-	    else if (oright->op_type != OP_PADAV
-		|| oright->op_targ != oleft->op_targ
-	    )
+	    oleft = is_inplace_av(o, oright);
+	    if (!oleft)
 		break;
 
 	    /* transfer MODishness etc from LHS arg to RHS arg */
@@ -8782,8 +9372,36 @@ Perl_peep(pTHX_ register OP *o)
 	case OP_REVERSE: {
 	    OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
 	    OP *gvop = NULL;
+	    OP *oleft, *oright;
 	    LISTOP *enter, *exlist;
 
+	    /* @a = reverse @a */
+	    if ((oright = cLISTOPo->op_first)
+		    && (oright->op_type == OP_PUSHMARK)
+		    && (oright = oright->op_sibling)
+		    && (oleft = is_inplace_av(o, oright))) {
+		OP *o2;
+
+		/* transfer MODishness etc from LHS arg to RHS arg */
+		oright->op_flags = oleft->op_flags;
+		o->op_private |= OPpREVERSE_INPLACE;
+
+		/* excise push->gv->rv2av->null->aassign */
+		o2 = o->op_next->op_next;
+		op_null(o2); /* PUSHMARK */
+		o2 = o2->op_next;
+		if (o2->op_type == OP_GV) {
+		    op_null(o2); /* GV */
+		    o2 = o2->op_next;
+		}
+		op_null(o2); /* RV2AV or PADAV */
+		o2 = o2->op_next->op_next;
+		op_null(o2); /* AASSIGN */
+
+		o->op_next = o2->op_next;
+		break;
+	    }
+
 	    enter = (LISTOP *) o->op_next;
 	    if (!enter)
 		break;
@@ -8925,6 +9543,12 @@ Perl_peep(pTHX_ register OP *o)
     LEAVE;
 }
 
+void
+Perl_peep(pTHX_ register OP *o)
+{
+    CALL_RPEEP(o);
+}
+
 const char*
 Perl_custom_op_name(pTHX_ const OP* o)
 {