xref: /openbsd-src/gnu/usr.bin/perl/op.c (revision 0b7734b3d77bb9b21afec6f4621cae6c805dbd45)
1 #line 2 "op.c"
2 /*    op.c
3  *
4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6  *
7  *    You may distribute under the terms of either the GNU General Public
8  *    License or the Artistic License, as specified in the README file.
9  *
10  */
11 
12 /*
13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
17  *  either way, as the saying is, if you follow me.'       --the Gaffer
18  *
19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20  */
21 
22 /* This file contains the functions that create, manipulate and optimize
23  * the OP structures that hold a compiled perl program.
24  *
25  * A Perl program is compiled into a tree of OPs. Each op contains
26  * structural pointers (eg to its siblings and the next op in the
27  * execution sequence), a pointer to the function that would execute the
28  * op, plus any data specific to that op. For example, an OP_CONST op
29  * points to the pp_const() function and to an SV containing the constant
30  * value. When pp_const() is executed, its job is to push that SV onto the
31  * stack.
32  *
33  * OPs are mainly created by the newFOO() functions, which are mainly
34  * called from the parser (in perly.y) as the code is parsed. For example
35  * the Perl code $a + $b * $c would cause the equivalent of the following
36  * to be called (oversimplifying a bit):
37  *
38  *  newBINOP(OP_ADD, flags,
39  *	newSVREF($a),
40  *	newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41  *  )
42  *
43  * Note that during the build of miniperl, a temporary copy of this file
44  * is made, called opmini.c.
45  */
46 
47 /*
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 
50     A bottom-up pass
51     A top-down pass
52     An execution-order pass
53 
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines.  The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order.  (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
61 top level node.)
62 
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again).  As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node.  But
70 it's still not the real execution order.
71 
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer.  At that point, we can call
75 into peep() to do that code's portion of the 3rd pass.  It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
77 */
78 
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80    get the compile time state of %^H for that block.  Storing %^H in every
81    block (or even COP) would be very expensive, so a different approach is
82    taken.  The (running) state of %^H is serialised into a tree of HE-like
83    structs.  Stores into %^H are chained onto the current leaf as a struct
84    refcounted_he * with the key and the value.  Deletes from %^H are saved
85    with a value of PL_sv_placeholder.  The state of %^H at any point can be
86    turned back into a regular HV by walking back up the tree from that point's
87    leaf, ignoring any key you've already seen (placeholder or not), storing
88    the rest into the HV structure, then removing the placeholders. Hence
89    memory is only used to store the %^H deltas from the enclosing COP, rather
90    than the entire %^H on each COP.
91 
92    To cause actions on %^H to write out the serialisation records, it has
93    magic type 'H'. This magic (itself) does nothing, but its presence causes
94    the values to gain magic type 'h', which has entries for set and clear.
95    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98    it will be correctly restored when any inner compiling scope is exited.
99 */
100 
101 #include "EXTERN.h"
102 #define PERL_IN_OP_C
103 #include "perl.h"
104 #include "keywords.h"
105 #include "feature.h"
106 #include "regcomp.h"
107 
108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
111 
112 /* remove any leading "empty" ops from the op_next chain whose first
113  * node's address is stored in op_p. Store the updated address of the
114  * first node in op_p.
115  */
116 
117 STATIC void
118 S_prune_chain_head(pTHX_ OP** op_p)
119 {
120     while (*op_p
121         && (   (*op_p)->op_type == OP_NULL
122             || (*op_p)->op_type == OP_SCOPE
123             || (*op_p)->op_type == OP_SCALAR
124             || (*op_p)->op_type == OP_LINESEQ)
125     )
126         *op_p = (*op_p)->op_next;
127 }
128 
129 
130 /* See the explanatory comments above struct opslab in op.h. */
131 
132 #ifdef PERL_DEBUG_READONLY_OPS
133 #  define PERL_SLAB_SIZE 128
134 #  define PERL_MAX_SLAB_SIZE 4096
135 #  include <sys/mman.h>
136 #endif
137 
138 #ifndef PERL_SLAB_SIZE
139 #  define PERL_SLAB_SIZE 64
140 #endif
141 #ifndef PERL_MAX_SLAB_SIZE
142 #  define PERL_MAX_SLAB_SIZE 2048
143 #endif
144 
145 /* rounds up to nearest pointer */
146 #define SIZE_TO_PSIZE(x)	(((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
147 #define DIFF(o,p)		((size_t)((I32 **)(p) - (I32**)(o)))
148 
149 static OPSLAB *
150 S_new_slab(pTHX_ size_t sz)
151 {
152 #ifdef PERL_DEBUG_READONLY_OPS
153     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
154 				   PROT_READ|PROT_WRITE,
155 				   MAP_ANON|MAP_PRIVATE, -1, 0);
156     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
157 			  (unsigned long) sz, slab));
158     if (slab == MAP_FAILED) {
159 	perror("mmap failed");
160 	abort();
161     }
162     slab->opslab_size = (U16)sz;
163 #else
164     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
165 #endif
166     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
167     return slab;
168 }
169 
170 /* requires double parens and aTHX_ */
171 #define DEBUG_S_warn(args)					       \
172     DEBUG_S( 								\
173 	PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
174     )
175 
176 void *
177 Perl_Slab_Alloc(pTHX_ size_t sz)
178 {
179     dVAR;
180     OPSLAB *slab;
181     OPSLAB *slab2;
182     OPSLOT *slot;
183     OP *o;
184     size_t opsz, space;
185 
186     /* We only allocate ops from the slab during subroutine compilation.
187        We find the slab via PL_compcv, hence that must be non-NULL. It could
188        also be pointing to a subroutine which is now fully set up (CvROOT()
189        pointing to the top of the optree for that sub), or a subroutine
190        which isn't using the slab allocator. If our sanity checks aren't met,
191        don't use a slab, but allocate the OP directly from the heap.  */
192     if (!PL_compcv || CvROOT(PL_compcv)
193      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
194 	return PerlMemShared_calloc(1, sz);
195 
196     /* While the subroutine is under construction, the slabs are accessed via
197        CvSTART(), to avoid needing to expand PVCV by one pointer for something
198        unneeded at runtime. Once a subroutine is constructed, the slabs are
199        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
200        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
201        details.  */
202     if (!CvSTART(PL_compcv)) {
203 	CvSTART(PL_compcv) =
204 	    (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
205 	CvSLABBED_on(PL_compcv);
206 	slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
207     }
208     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
209 
210     opsz = SIZE_TO_PSIZE(sz);
211     sz = opsz + OPSLOT_HEADER_P;
212 
213     /* The slabs maintain a free list of OPs. In particular, constant folding
214        will free up OPs, so it makes sense to re-use them where possible. A
215        freed up slot is used in preference to a new allocation.  */
216     if (slab->opslab_freed) {
217 	OP **too = &slab->opslab_freed;
218 	o = *too;
219 	DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
220 	while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
221 	    DEBUG_S_warn((aTHX_ "Alas! too small"));
222 	    o = *(too = &o->op_next);
223 	    if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
224 	}
225 	if (o) {
226 	    *too = o->op_next;
227 	    Zero(o, opsz, I32 *);
228 	    o->op_slabbed = 1;
229 	    return (void *)o;
230 	}
231     }
232 
233 #define INIT_OPSLOT \
234 	    slot->opslot_slab = slab;			\
235 	    slot->opslot_next = slab2->opslab_first;	\
236 	    slab2->opslab_first = slot;			\
237 	    o = &slot->opslot_op;			\
238 	    o->op_slabbed = 1
239 
240     /* The partially-filled slab is next in the chain. */
241     slab2 = slab->opslab_next ? slab->opslab_next : slab;
242     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
243 	/* Remaining space is too small. */
244 
245 	/* If we can fit a BASEOP, add it to the free chain, so as not
246 	   to waste it. */
247 	if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
248 	    slot = &slab2->opslab_slots;
249 	    INIT_OPSLOT;
250 	    o->op_type = OP_FREED;
251 	    o->op_next = slab->opslab_freed;
252 	    slab->opslab_freed = o;
253 	}
254 
255 	/* Create a new slab.  Make this one twice as big. */
256 	slot = slab2->opslab_first;
257 	while (slot->opslot_next) slot = slot->opslot_next;
258 	slab2 = S_new_slab(aTHX_
259 			    (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
260 					? PERL_MAX_SLAB_SIZE
261 					: (DIFF(slab2, slot)+1)*2);
262 	slab2->opslab_next = slab->opslab_next;
263 	slab->opslab_next = slab2;
264     }
265     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
266 
267     /* Create a new op slot */
268     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
269     assert(slot >= &slab2->opslab_slots);
270     if (DIFF(&slab2->opslab_slots, slot)
271 	 < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
272 	slot = &slab2->opslab_slots;
273     INIT_OPSLOT;
274     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
275     return (void *)o;
276 }
277 
278 #undef INIT_OPSLOT
279 
280 #ifdef PERL_DEBUG_READONLY_OPS
281 void
282 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
283 {
284     PERL_ARGS_ASSERT_SLAB_TO_RO;
285 
286     if (slab->opslab_readonly) return;
287     slab->opslab_readonly = 1;
288     for (; slab; slab = slab->opslab_next) {
289 	/*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
290 			      (unsigned long) slab->opslab_size, slab));*/
291 	if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
292 	    Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
293 			     (unsigned long)slab->opslab_size, errno);
294     }
295 }
296 
297 void
298 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
299 {
300     OPSLAB *slab2;
301 
302     PERL_ARGS_ASSERT_SLAB_TO_RW;
303 
304     if (!slab->opslab_readonly) return;
305     slab2 = slab;
306     for (; slab2; slab2 = slab2->opslab_next) {
307 	/*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
308 			      (unsigned long) size, slab2));*/
309 	if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
310 		     PROT_READ|PROT_WRITE)) {
311 	    Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
312 			     (unsigned long)slab2->opslab_size, errno);
313 	}
314     }
315     slab->opslab_readonly = 0;
316 }
317 
318 #else
319 #  define Slab_to_rw(op)    NOOP
320 #endif
321 
322 /* This cannot possibly be right, but it was copied from the old slab
323    allocator, to which it was originally added, without explanation, in
324    commit 083fcd5. */
325 #ifdef NETWARE
326 #    define PerlMemShared PerlMem
327 #endif
328 
329 void
330 Perl_Slab_Free(pTHX_ void *op)
331 {
332     dVAR;
333     OP * const o = (OP *)op;
334     OPSLAB *slab;
335 
336     PERL_ARGS_ASSERT_SLAB_FREE;
337 
338     if (!o->op_slabbed) {
339         if (!o->op_static)
340 	    PerlMemShared_free(op);
341 	return;
342     }
343 
344     slab = OpSLAB(o);
345     /* If this op is already freed, our refcount will get screwy. */
346     assert(o->op_type != OP_FREED);
347     o->op_type = OP_FREED;
348     o->op_next = slab->opslab_freed;
349     slab->opslab_freed = o;
350     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
351     OpslabREFCNT_dec_padok(slab);
352 }
353 
354 void
355 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
356 {
357     dVAR;
358     const bool havepad = !!PL_comppad;
359     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
360     if (havepad) {
361 	ENTER;
362 	PAD_SAVE_SETNULLPAD();
363     }
364     opslab_free(slab);
365     if (havepad) LEAVE;
366 }
367 
368 void
369 Perl_opslab_free(pTHX_ OPSLAB *slab)
370 {
371     dVAR;
372     OPSLAB *slab2;
373     PERL_ARGS_ASSERT_OPSLAB_FREE;
374     DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
375     assert(slab->opslab_refcnt == 1);
376     for (; slab; slab = slab2) {
377 	slab2 = slab->opslab_next;
378 #ifdef DEBUGGING
379 	slab->opslab_refcnt = ~(size_t)0;
380 #endif
381 #ifdef PERL_DEBUG_READONLY_OPS
382 	DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
383 					       slab));
384 	if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
385 	    perror("munmap failed");
386 	    abort();
387 	}
388 #else
389 	PerlMemShared_free(slab);
390 #endif
391     }
392 }
393 
394 void
395 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
396 {
397     OPSLAB *slab2;
398     OPSLOT *slot;
399 #ifdef DEBUGGING
400     size_t savestack_count = 0;
401 #endif
402     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
403     slab2 = slab;
404     do {
405 	for (slot = slab2->opslab_first;
406 	     slot->opslot_next;
407 	     slot = slot->opslot_next) {
408 	    if (slot->opslot_op.op_type != OP_FREED
409 	     && !(slot->opslot_op.op_savefree
410 #ifdef DEBUGGING
411 		  && ++savestack_count
412 #endif
413 		 )
414 	    ) {
415 		assert(slot->opslot_op.op_slabbed);
416 		op_free(&slot->opslot_op);
417 		if (slab->opslab_refcnt == 1) goto free;
418 	    }
419 	}
420     } while ((slab2 = slab2->opslab_next));
421     /* > 1 because the CV still holds a reference count. */
422     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
423 #ifdef DEBUGGING
424 	assert(savestack_count == slab->opslab_refcnt-1);
425 #endif
426 	/* Remove the CV’s reference count. */
427 	slab->opslab_refcnt--;
428 	return;
429     }
430    free:
431     opslab_free(slab);
432 }
433 
434 #ifdef PERL_DEBUG_READONLY_OPS
435 OP *
436 Perl_op_refcnt_inc(pTHX_ OP *o)
437 {
438     if(o) {
439         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
440         if (slab && slab->opslab_readonly) {
441             Slab_to_rw(slab);
442             ++o->op_targ;
443             Slab_to_ro(slab);
444         } else {
445             ++o->op_targ;
446         }
447     }
448     return o;
449 
450 }
451 
452 PADOFFSET
453 Perl_op_refcnt_dec(pTHX_ OP *o)
454 {
455     PADOFFSET result;
456     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
457 
458     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
459 
460     if (slab && slab->opslab_readonly) {
461         Slab_to_rw(slab);
462         result = --o->op_targ;
463         Slab_to_ro(slab);
464     } else {
465         result = --o->op_targ;
466     }
467     return result;
468 }
469 #endif
470 /*
471  * In the following definition, the ", (OP*)0" is just to make the compiler
472  * think the expression is of the right type: croak actually does a Siglongjmp.
473  */
474 #define CHECKOP(type,o) \
475     ((PL_op_mask && PL_op_mask[type])				\
476      ? ( op_free((OP*)o),					\
477 	 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),	\
478 	 (OP*)0 )						\
479      : PL_check[type](aTHX_ (OP*)o))
480 
481 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
482 
483 #define CHANGE_TYPE(o,type) \
484     STMT_START {				\
485 	o->op_type = (OPCODE)type;		\
486 	o->op_ppaddr = PL_ppaddr[type];		\
487     } STMT_END
488 
489 STATIC SV*
490 S_gv_ename(pTHX_ GV *gv)
491 {
492     SV* const tmpsv = sv_newmortal();
493 
494     PERL_ARGS_ASSERT_GV_ENAME;
495 
496     gv_efullname3(tmpsv, gv, NULL);
497     return tmpsv;
498 }
499 
500 STATIC OP *
501 S_no_fh_allowed(pTHX_ OP *o)
502 {
503     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
504 
505     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
506 		 OP_DESC(o)));
507     return o;
508 }
509 
510 STATIC OP *
511 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
512 {
513     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
514     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
515                                     SvUTF8(namesv) | flags);
516     return o;
517 }
518 
519 STATIC OP *
520 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
521 {
522     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
523     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
524     return o;
525 }
526 
527 STATIC OP *
528 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
529 {
530     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
531 
532     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
533     return o;
534 }
535 
536 STATIC OP *
537 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
538 {
539     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
540 
541     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
542                 SvUTF8(namesv) | flags);
543     return o;
544 }
545 
546 STATIC void
547 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
548 {
549     PERL_ARGS_ASSERT_BAD_TYPE_PV;
550 
551     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
552 		 (int)n, name, t, OP_DESC(kid)), flags);
553 }
554 
555 STATIC void
556 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
557 {
558     SV * const namesv = gv_ename(gv);
559     PERL_ARGS_ASSERT_BAD_TYPE_GV;
560 
561     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
562 		 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
563 }
564 
565 STATIC void
566 S_no_bareword_allowed(pTHX_ OP *o)
567 {
568     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
569 
570     if (PL_madskills)
571 	return;		/* various ok barewords are hidden in extra OP_NULL */
572     qerror(Perl_mess(aTHX_
573 		     "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
574 		     SVfARG(cSVOPo_sv)));
575     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
576 }
577 
578 /* "register" allocation */
579 
580 PADOFFSET
581 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
582 {
583     dVAR;
584     PADOFFSET off;
585     const bool is_our = (PL_parser->in_my == KEY_our);
586 
587     PERL_ARGS_ASSERT_ALLOCMY;
588 
589     if (flags & ~SVf_UTF8)
590 	Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
591 		   (UV)flags);
592 
593     /* Until we're using the length for real, cross check that we're being
594        told the truth.  */
595     assert(strlen(name) == len);
596 
597     /* complain about "my $<special_var>" etc etc */
598     if (len &&
599 	!(is_our ||
600 	  isALPHA(name[1]) ||
601 	  ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
602 	  (name[1] == '_' && (*name == '$' || len > 2))))
603     {
604 	/* name[2] is true if strlen(name) > 2  */
605 	if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
606 	 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
607 	    yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
608 			      name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
609 			      PL_parser->in_my == KEY_state ? "state" : "my"));
610 	} else {
611 	    yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
612 			      PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
613 	}
614     }
615     else if (len == 2 && name[1] == '_' && !is_our)
616 	/* diag_listed_as: Use of my $_ is experimental */
617 	Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
618 			      "Use of %s $_ is experimental",
619 			       PL_parser->in_my == KEY_state
620 				 ? "state"
621 				 : "my");
622 
623     /* allocate a spare slot and store the name in that slot */
624 
625     off = pad_add_name_pvn(name, len,
626 		       (is_our ? padadd_OUR :
627 		        PL_parser->in_my == KEY_state ? padadd_STATE : 0)
628                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
629 		    PL_parser->in_my_stash,
630 		    (is_our
631 		        /* $_ is always in main::, even with our */
632 			? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
633 			: NULL
634 		    )
635     );
636     /* anon sub prototypes contains state vars should always be cloned,
637      * otherwise the state var would be shared between anon subs */
638 
639     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
640 	CvCLONE_on(PL_compcv);
641 
642     return off;
643 }
644 
645 /*
646 =for apidoc alloccopstash
647 
648 Available only under threaded builds, this function allocates an entry in
649 C<PL_stashpad> for the stash passed to it.
650 
651 =cut
652 */
653 
654 #ifdef USE_ITHREADS
655 PADOFFSET
656 Perl_alloccopstash(pTHX_ HV *hv)
657 {
658     PADOFFSET off = 0, o = 1;
659     bool found_slot = FALSE;
660 
661     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
662 
663     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
664 
665     for (; o < PL_stashpadmax; ++o) {
666 	if (PL_stashpad[o] == hv) return PL_stashpadix = o;
667 	if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
668 	    found_slot = TRUE, off = o;
669     }
670     if (!found_slot) {
671 	Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
672 	Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
673 	off = PL_stashpadmax;
674 	PL_stashpadmax += 10;
675     }
676 
677     PL_stashpad[PL_stashpadix = off] = hv;
678     return off;
679 }
680 #endif
681 
682 /* free the body of an op without examining its contents.
683  * Always use this rather than FreeOp directly */
684 
685 static void
686 S_op_destroy(pTHX_ OP *o)
687 {
688     FreeOp(o);
689 }
690 
691 /* Destructor */
692 
693 /*
694 =for apidoc Am|void|op_free|OP *o
695 
696 Free an op.  Only use this when an op is no longer linked to from any
697 optree.
698 
699 =cut
700 */
701 
702 void
703 Perl_op_free(pTHX_ OP *o)
704 {
705     dVAR;
706     OPCODE type;
707 
708     /* Though ops may be freed twice, freeing the op after its slab is a
709        big no-no. */
710     assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
711     /* During the forced freeing of ops after compilation failure, kidops
712        may be freed before their parents. */
713     if (!o || o->op_type == OP_FREED)
714 	return;
715 
716     type = o->op_type;
717     if (o->op_private & OPpREFCOUNTED) {
718 	switch (type) {
719 	case OP_LEAVESUB:
720 	case OP_LEAVESUBLV:
721 	case OP_LEAVEEVAL:
722 	case OP_LEAVE:
723 	case OP_SCOPE:
724 	case OP_LEAVEWRITE:
725 	    {
726 	    PADOFFSET refcnt;
727 	    OP_REFCNT_LOCK;
728 	    refcnt = OpREFCNT_dec(o);
729 	    OP_REFCNT_UNLOCK;
730 	    if (refcnt) {
731 		/* Need to find and remove any pattern match ops from the list
732 		   we maintain for reset().  */
733 		find_and_forget_pmops(o);
734 		return;
735 	    }
736 	    }
737 	    break;
738 	default:
739 	    break;
740 	}
741     }
742 
743     /* Call the op_free hook if it has been set. Do it now so that it's called
744      * at the right time for refcounted ops, but still before all of the kids
745      * are freed. */
746     CALL_OPFREEHOOK(o);
747 
748     if (o->op_flags & OPf_KIDS) {
749         OP *kid, *nextkid;
750 	for (kid = cUNOPo->op_first; kid; kid = nextkid) {
751 	    nextkid = kid->op_sibling; /* Get before next freeing kid */
752 	    op_free(kid);
753 	}
754     }
755     if (type == OP_NULL)
756 	type = (OPCODE)o->op_targ;
757 
758     if (o->op_slabbed)
759         Slab_to_rw(OpSLAB(o));
760 
761     /* COP* is not cleared by op_clear() so that we may track line
762      * numbers etc even after null() */
763     if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
764 	cop_free((COP*)o);
765     }
766 
767     op_clear(o);
768     FreeOp(o);
769 #ifdef DEBUG_LEAKING_SCALARS
770     if (PL_op == o)
771 	PL_op = NULL;
772 #endif
773 }
774 
775 void
776 Perl_op_clear(pTHX_ OP *o)
777 {
778 
779     dVAR;
780 
781     PERL_ARGS_ASSERT_OP_CLEAR;
782 
783 #ifdef PERL_MAD
784     mad_free(o->op_madprop);
785     o->op_madprop = 0;
786 #endif
787 
788  retry:
789     switch (o->op_type) {
790     case OP_NULL:	/* Was holding old type, if any. */
791 	if (PL_madskills && o->op_targ != OP_NULL) {
792 	    o->op_type = (Optype)o->op_targ;
793 	    o->op_targ = 0;
794 	    goto retry;
795 	}
796     case OP_ENTERTRY:
797     case OP_ENTEREVAL:	/* Was holding hints. */
798 	o->op_targ = 0;
799 	break;
800     default:
801 	if (!(o->op_flags & OPf_REF)
802 	    || (PL_check[o->op_type] != Perl_ck_ftst))
803 	    break;
804 	/* FALL THROUGH */
805     case OP_GVSV:
806     case OP_GV:
807     case OP_AELEMFAST:
808 	{
809 	    GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
810 #ifdef USE_ITHREADS
811 			&& PL_curpad
812 #endif
813 			? cGVOPo_gv : NULL;
814 	    /* It's possible during global destruction that the GV is freed
815 	       before the optree. Whilst the SvREFCNT_inc is happy to bump from
816 	       0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
817 	       will trigger an assertion failure, because the entry to sv_clear
818 	       checks that the scalar is not already freed.  A check of for
819 	       !SvIS_FREED(gv) turns out to be invalid, because during global
820 	       destruction the reference count can be forced down to zero
821 	       (with SVf_BREAK set).  In which case raising to 1 and then
822 	       dropping to 0 triggers cleanup before it should happen.  I
823 	       *think* that this might actually be a general, systematic,
824 	       weakness of the whole idea of SVf_BREAK, in that code *is*
825 	       allowed to raise and lower references during global destruction,
826 	       so any *valid* code that happens to do this during global
827 	       destruction might well trigger premature cleanup.  */
828 	    bool still_valid = gv && SvREFCNT(gv);
829 
830 	    if (still_valid)
831 		SvREFCNT_inc_simple_void(gv);
832 #ifdef USE_ITHREADS
833 	    if (cPADOPo->op_padix > 0) {
834 		/* No GvIN_PAD_off(cGVOPo_gv) here, because other references
835 		 * may still exist on the pad */
836 		pad_swipe(cPADOPo->op_padix, TRUE);
837 		cPADOPo->op_padix = 0;
838 	    }
839 #else
840 	    SvREFCNT_dec(cSVOPo->op_sv);
841 	    cSVOPo->op_sv = NULL;
842 #endif
843 	    if (still_valid) {
844 		int try_downgrade = SvREFCNT(gv) == 2;
845 		SvREFCNT_dec_NN(gv);
846 		if (try_downgrade)
847 		    gv_try_downgrade(gv);
848 	    }
849 	}
850 	break;
851     case OP_METHOD_NAMED:
852     case OP_CONST:
853     case OP_HINTSEVAL:
854 	SvREFCNT_dec(cSVOPo->op_sv);
855 	cSVOPo->op_sv = NULL;
856 #ifdef USE_ITHREADS
857 	/** Bug #15654
858 	  Even if op_clear does a pad_free for the target of the op,
859 	  pad_free doesn't actually remove the sv that exists in the pad;
860 	  instead it lives on. This results in that it could be reused as
861 	  a target later on when the pad was reallocated.
862 	**/
863         if(o->op_targ) {
864           pad_swipe(o->op_targ,1);
865           o->op_targ = 0;
866         }
867 #endif
868 	break;
869     case OP_DUMP:
870     case OP_GOTO:
871     case OP_NEXT:
872     case OP_LAST:
873     case OP_REDO:
874 	if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
875 	    break;
876 	/* FALL THROUGH */
877     case OP_TRANS:
878     case OP_TRANSR:
879 	if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
880 	    assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
881 #ifdef USE_ITHREADS
882 	    if (cPADOPo->op_padix > 0) {
883 		pad_swipe(cPADOPo->op_padix, TRUE);
884 		cPADOPo->op_padix = 0;
885 	    }
886 #else
887 	    SvREFCNT_dec(cSVOPo->op_sv);
888 	    cSVOPo->op_sv = NULL;
889 #endif
890 	}
891 	else {
892 	    PerlMemShared_free(cPVOPo->op_pv);
893 	    cPVOPo->op_pv = NULL;
894 	}
895 	break;
896     case OP_SUBST:
897 	op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
898 	goto clear_pmop;
899     case OP_PUSHRE:
900 #ifdef USE_ITHREADS
901         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
902 	    /* No GvIN_PAD_off here, because other references may still
903 	     * exist on the pad */
904 	    pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
905 	}
906 #else
907 	SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
908 #endif
909 	/* FALL THROUGH */
910     case OP_MATCH:
911     case OP_QR:
912 clear_pmop:
913 	if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
914 	    op_free(cPMOPo->op_code_list);
915 	cPMOPo->op_code_list = NULL;
916 	forget_pmop(cPMOPo);
917 	cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
918         /* we use the same protection as the "SAFE" version of the PM_ macros
919          * here since sv_clean_all might release some PMOPs
920          * after PL_regex_padav has been cleared
921          * and the clearing of PL_regex_padav needs to
922          * happen before sv_clean_all
923          */
924 #ifdef USE_ITHREADS
925 	if(PL_regex_pad) {        /* We could be in destruction */
926 	    const IV offset = (cPMOPo)->op_pmoffset;
927 	    ReREFCNT_dec(PM_GETRE(cPMOPo));
928 	    PL_regex_pad[offset] = &PL_sv_undef;
929             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
930 			   sizeof(offset));
931         }
932 #else
933 	ReREFCNT_dec(PM_GETRE(cPMOPo));
934 	PM_SETRE(cPMOPo, NULL);
935 #endif
936 
937 	break;
938     }
939 
940     if (o->op_targ > 0) {
941 	pad_free(o->op_targ);
942 	o->op_targ = 0;
943     }
944 }
945 
946 STATIC void
947 S_cop_free(pTHX_ COP* cop)
948 {
949     PERL_ARGS_ASSERT_COP_FREE;
950 
951     CopFILE_free(cop);
952     if (! specialWARN(cop->cop_warnings))
953 	PerlMemShared_free(cop->cop_warnings);
954     cophh_free(CopHINTHASH_get(cop));
955     if (PL_curcop == cop)
956        PL_curcop = NULL;
957 }
958 
959 STATIC void
960 S_forget_pmop(pTHX_ PMOP *const o
961 	      )
962 {
963     HV * const pmstash = PmopSTASH(o);
964 
965     PERL_ARGS_ASSERT_FORGET_PMOP;
966 
967     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
968 	MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
969 	if (mg) {
970 	    PMOP **const array = (PMOP**) mg->mg_ptr;
971 	    U32 count = mg->mg_len / sizeof(PMOP**);
972 	    U32 i = count;
973 
974 	    while (i--) {
975 		if (array[i] == o) {
976 		    /* Found it. Move the entry at the end to overwrite it.  */
977 		    array[i] = array[--count];
978 		    mg->mg_len = count * sizeof(PMOP**);
979 		    /* Could realloc smaller at this point always, but probably
980 		       not worth it. Probably worth free()ing if we're the
981 		       last.  */
982 		    if(!count) {
983 			Safefree(mg->mg_ptr);
984 			mg->mg_ptr = NULL;
985 		    }
986 		    break;
987 		}
988 	    }
989 	}
990     }
991     if (PL_curpm == o)
992 	PL_curpm = NULL;
993 }
994 
995 STATIC void
996 S_find_and_forget_pmops(pTHX_ OP *o)
997 {
998     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
999 
1000     if (o->op_flags & OPf_KIDS) {
1001         OP *kid = cUNOPo->op_first;
1002 	while (kid) {
1003 	    switch (kid->op_type) {
1004 	    case OP_SUBST:
1005 	    case OP_PUSHRE:
1006 	    case OP_MATCH:
1007 	    case OP_QR:
1008 		forget_pmop((PMOP*)kid);
1009 	    }
1010 	    find_and_forget_pmops(kid);
1011 	    kid = kid->op_sibling;
1012 	}
1013     }
1014 }
1015 
1016 /*
1017 =for apidoc Am|void|op_null|OP *o
1018 
1019 Neutralizes an op when it is no longer needed, but is still linked to from
1020 other ops.
1021 
1022 =cut
1023 */
1024 
1025 void
1026 Perl_op_null(pTHX_ OP *o)
1027 {
1028     dVAR;
1029 
1030     PERL_ARGS_ASSERT_OP_NULL;
1031 
1032     if (o->op_type == OP_NULL)
1033 	return;
1034     if (!PL_madskills)
1035 	op_clear(o);
1036     o->op_targ = o->op_type;
1037     o->op_type = OP_NULL;
1038     o->op_ppaddr = PL_ppaddr[OP_NULL];
1039 }
1040 
1041 void
1042 Perl_op_refcnt_lock(pTHX)
1043 {
1044     dVAR;
1045     PERL_UNUSED_CONTEXT;
1046     OP_REFCNT_LOCK;
1047 }
1048 
1049 void
1050 Perl_op_refcnt_unlock(pTHX)
1051 {
1052     dVAR;
1053     PERL_UNUSED_CONTEXT;
1054     OP_REFCNT_UNLOCK;
1055 }
1056 
1057 /* Contextualizers */
1058 
1059 /*
1060 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1061 
1062 Applies a syntactic context to an op tree representing an expression.
1063 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1064 or C<G_VOID> to specify the context to apply.  The modified op tree
1065 is returned.
1066 
1067 =cut
1068 */
1069 
1070 OP *
1071 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1072 {
1073     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1074     switch (context) {
1075 	case G_SCALAR: return scalar(o);
1076 	case G_ARRAY:  return list(o);
1077 	case G_VOID:   return scalarvoid(o);
1078 	default:
1079 	    Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1080 		       (long) context);
1081 	    return o;
1082     }
1083 }
1084 
1085 /*
1086 =head1 Optree Manipulation Functions
1087 
1088 =for apidoc Am|OP*|op_linklist|OP *o
1089 This function is the implementation of the L</LINKLIST> macro.  It should
1090 not be called directly.
1091 
1092 =cut
1093 */
1094 
1095 OP *
1096 Perl_op_linklist(pTHX_ OP *o)
1097 {
1098     OP *first;
1099 
1100     PERL_ARGS_ASSERT_OP_LINKLIST;
1101 
1102     if (o->op_next)
1103 	return o->op_next;
1104 
1105     /* establish postfix order */
1106     first = cUNOPo->op_first;
1107     if (first) {
1108         OP *kid;
1109 	o->op_next = LINKLIST(first);
1110 	kid = first;
1111 	for (;;) {
1112 	    if (kid->op_sibling) {
1113 		kid->op_next = LINKLIST(kid->op_sibling);
1114 		kid = kid->op_sibling;
1115 	    } else {
1116 		kid->op_next = o;
1117 		break;
1118 	    }
1119 	}
1120     }
1121     else
1122 	o->op_next = o;
1123 
1124     return o->op_next;
1125 }
1126 
1127 static OP *
1128 S_scalarkids(pTHX_ OP *o)
1129 {
1130     if (o && o->op_flags & OPf_KIDS) {
1131         OP *kid;
1132 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1133 	    scalar(kid);
1134     }
1135     return o;
1136 }
1137 
1138 STATIC OP *
1139 S_scalarboolean(pTHX_ OP *o)
1140 {
1141     dVAR;
1142 
1143     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1144 
1145     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1146      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1147 	if (ckWARN(WARN_SYNTAX)) {
1148 	    const line_t oldline = CopLINE(PL_curcop);
1149 
1150 	    if (PL_parser && PL_parser->copline != NOLINE) {
1151 		/* This ensures that warnings are reported at the first line
1152                    of the conditional, not the last.  */
1153 		CopLINE_set(PL_curcop, PL_parser->copline);
1154             }
1155 	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1156 	    CopLINE_set(PL_curcop, oldline);
1157 	}
1158     }
1159     return scalar(o);
1160 }
1161 
1162 static SV *
1163 S_op_varname(pTHX_ const OP *o)
1164 {
1165     assert(o);
1166     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1167 	   o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1168     {
1169 	const char funny  = o->op_type == OP_PADAV
1170 			 || o->op_type == OP_RV2AV ? '@' : '%';
1171 	if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1172 	    GV *gv;
1173 	    if (cUNOPo->op_first->op_type != OP_GV
1174 	     || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1175 		return NULL;
1176 	    return varname(gv, funny, 0, NULL, 0, 1);
1177 	}
1178 	return
1179 	    varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1180     }
1181 }
1182 
1183 static void
1184 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1185 { /* or not so pretty :-) */
1186     if (o->op_type == OP_CONST) {
1187 	*retsv = cSVOPo_sv;
1188 	if (SvPOK(*retsv)) {
1189 	    SV *sv = *retsv;
1190 	    *retsv = sv_newmortal();
1191 	    pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1192 		      PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1193 	}
1194 	else if (!SvOK(*retsv))
1195 	    *retpv = "undef";
1196     }
1197     else *retpv = "...";
1198 }
1199 
1200 static void
1201 S_scalar_slice_warning(pTHX_ const OP *o)
1202 {
1203     OP *kid;
1204     const char lbrack =
1205 	o->op_type == OP_HSLICE ? '{' : '[';
1206     const char rbrack =
1207 	o->op_type == OP_HSLICE ? '}' : ']';
1208     SV *name;
1209     SV *keysv = NULL; /* just to silence compiler warnings */
1210     const char *key = NULL;
1211 
1212     if (!(o->op_private & OPpSLICEWARNING))
1213 	return;
1214     if (PL_parser && PL_parser->error_count)
1215 	/* This warning can be nonsensical when there is a syntax error. */
1216 	return;
1217 
1218     kid = cLISTOPo->op_first;
1219     kid = kid->op_sibling; /* get past pushmark */
1220     /* weed out false positives: any ops that can return lists */
1221     switch (kid->op_type) {
1222     case OP_BACKTICK:
1223     case OP_GLOB:
1224     case OP_READLINE:
1225     case OP_MATCH:
1226     case OP_RV2AV:
1227     case OP_EACH:
1228     case OP_VALUES:
1229     case OP_KEYS:
1230     case OP_SPLIT:
1231     case OP_LIST:
1232     case OP_SORT:
1233     case OP_REVERSE:
1234     case OP_ENTERSUB:
1235     case OP_CALLER:
1236     case OP_LSTAT:
1237     case OP_STAT:
1238     case OP_READDIR:
1239     case OP_SYSTEM:
1240     case OP_TMS:
1241     case OP_LOCALTIME:
1242     case OP_GMTIME:
1243     case OP_ENTEREVAL:
1244     case OP_REACH:
1245     case OP_RKEYS:
1246     case OP_RVALUES:
1247 	return;
1248     }
1249 
1250     /* Don't warn if we have a nulled list either. */
1251     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1252         return;
1253 
1254     assert(kid->op_sibling);
1255     name = S_op_varname(aTHX_ kid->op_sibling);
1256     if (!name) /* XS module fiddling with the op tree */
1257 	return;
1258     S_op_pretty(aTHX_ kid, &keysv, &key);
1259     assert(SvPOK(name));
1260     sv_chop(name,SvPVX(name)+1);
1261     if (key)
1262        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1263 	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1264 		   "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1265 		   "%c%s%c",
1266 		    SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1267 		    lbrack, key, rbrack);
1268     else
1269        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1270 	Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1271 		   "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1272 		    SVf"%c%"SVf"%c",
1273 		    SVfARG(name), lbrack, keysv, rbrack,
1274 		    SVfARG(name), lbrack, keysv, rbrack);
1275 }
1276 
1277 OP *
1278 Perl_scalar(pTHX_ OP *o)
1279 {
1280     dVAR;
1281     OP *kid;
1282 
1283     /* assumes no premature commitment */
1284     if (!o || (PL_parser && PL_parser->error_count)
1285 	 || (o->op_flags & OPf_WANT)
1286 	 || o->op_type == OP_RETURN)
1287     {
1288 	return o;
1289     }
1290 
1291     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1292 
1293     switch (o->op_type) {
1294     case OP_REPEAT:
1295 	scalar(cBINOPo->op_first);
1296 	break;
1297     case OP_OR:
1298     case OP_AND:
1299     case OP_COND_EXPR:
1300 	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1301 	    scalar(kid);
1302 	break;
1303 	/* FALL THROUGH */
1304     case OP_SPLIT:
1305     case OP_MATCH:
1306     case OP_QR:
1307     case OP_SUBST:
1308     case OP_NULL:
1309     default:
1310 	if (o->op_flags & OPf_KIDS) {
1311 	    for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1312 		scalar(kid);
1313 	}
1314 	break;
1315     case OP_LEAVE:
1316     case OP_LEAVETRY:
1317 	kid = cLISTOPo->op_first;
1318 	scalar(kid);
1319 	kid = kid->op_sibling;
1320     do_kids:
1321 	while (kid) {
1322 	    OP *sib = kid->op_sibling;
1323 	    if (sib && kid->op_type != OP_LEAVEWHEN)
1324 		scalarvoid(kid);
1325 	    else
1326 		scalar(kid);
1327 	    kid = sib;
1328 	}
1329 	PL_curcop = &PL_compiling;
1330 	break;
1331     case OP_SCOPE:
1332     case OP_LINESEQ:
1333     case OP_LIST:
1334 	kid = cLISTOPo->op_first;
1335 	goto do_kids;
1336     case OP_SORT:
1337 	Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1338 	break;
1339     case OP_KVHSLICE:
1340     case OP_KVASLICE:
1341     {
1342 	/* Warn about scalar context */
1343 	const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1344 	const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1345 	SV *name;
1346 	SV *keysv;
1347 	const char *key = NULL;
1348 
1349 	/* This warning can be nonsensical when there is a syntax error. */
1350 	if (PL_parser && PL_parser->error_count)
1351 	    break;
1352 
1353 	if (!ckWARN(WARN_SYNTAX)) break;
1354 
1355 	kid = cLISTOPo->op_first;
1356 	kid = kid->op_sibling; /* get past pushmark */
1357 	assert(kid->op_sibling);
1358 	name = S_op_varname(aTHX_ kid->op_sibling);
1359 	if (!name) /* XS module fiddling with the op tree */
1360 	    break;
1361 	S_op_pretty(aTHX_ kid, &keysv, &key);
1362 	assert(SvPOK(name));
1363 	sv_chop(name,SvPVX(name)+1);
1364 	if (key)
1365   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1366 	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1367 		       "%%%"SVf"%c%s%c in scalar context better written "
1368 		       "as $%"SVf"%c%s%c",
1369 			SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1370 			lbrack, key, rbrack);
1371 	else
1372   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1373 	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1374 		       "%%%"SVf"%c%"SVf"%c in scalar context better "
1375 		       "written as $%"SVf"%c%"SVf"%c",
1376 			SVfARG(name), lbrack, keysv, rbrack,
1377 			SVfARG(name), lbrack, keysv, rbrack);
1378     }
1379     }
1380     return o;
1381 }
1382 
1383 OP *
1384 Perl_scalarvoid(pTHX_ OP *o)
1385 {
1386     dVAR;
1387     OP *kid;
1388     SV *useless_sv = NULL;
1389     const char* useless = NULL;
1390     SV* sv;
1391     U8 want;
1392 
1393     PERL_ARGS_ASSERT_SCALARVOID;
1394 
1395     /* trailing mad null ops don't count as "there" for void processing */
1396     if (PL_madskills &&
1397     	o->op_type != OP_NULL &&
1398 	o->op_sibling &&
1399 	o->op_sibling->op_type == OP_NULL)
1400     {
1401 	OP *sib;
1402 	for (sib = o->op_sibling;
1403 		sib && sib->op_type == OP_NULL;
1404 		sib = sib->op_sibling) ;
1405 
1406 	if (!sib)
1407 	    return o;
1408     }
1409 
1410     if (o->op_type == OP_NEXTSTATE
1411 	|| o->op_type == OP_DBSTATE
1412 	|| (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1413 				      || o->op_targ == OP_DBSTATE)))
1414 	PL_curcop = (COP*)o;		/* for warning below */
1415 
1416     /* assumes no premature commitment */
1417     want = o->op_flags & OPf_WANT;
1418     if ((want && want != OPf_WANT_SCALAR)
1419 	 || (PL_parser && PL_parser->error_count)
1420 	 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1421     {
1422 	return o;
1423     }
1424 
1425     if ((o->op_private & OPpTARGET_MY)
1426 	&& (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1427     {
1428 	return scalar(o);			/* As if inside SASSIGN */
1429     }
1430 
1431     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1432 
1433     switch (o->op_type) {
1434     default:
1435 	if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1436 	    break;
1437 	/* FALL THROUGH */
1438     case OP_REPEAT:
1439 	if (o->op_flags & OPf_STACKED)
1440 	    break;
1441 	goto func_ops;
1442     case OP_SUBSTR:
1443 	if (o->op_private == 4)
1444 	    break;
1445 	/* FALL THROUGH */
1446     case OP_GVSV:
1447     case OP_WANTARRAY:
1448     case OP_GV:
1449     case OP_SMARTMATCH:
1450     case OP_PADSV:
1451     case OP_PADAV:
1452     case OP_PADHV:
1453     case OP_PADANY:
1454     case OP_AV2ARYLEN:
1455     case OP_REF:
1456     case OP_REFGEN:
1457     case OP_SREFGEN:
1458     case OP_DEFINED:
1459     case OP_HEX:
1460     case OP_OCT:
1461     case OP_LENGTH:
1462     case OP_VEC:
1463     case OP_INDEX:
1464     case OP_RINDEX:
1465     case OP_SPRINTF:
1466     case OP_AELEM:
1467     case OP_AELEMFAST:
1468     case OP_AELEMFAST_LEX:
1469     case OP_ASLICE:
1470     case OP_KVASLICE:
1471     case OP_HELEM:
1472     case OP_HSLICE:
1473     case OP_KVHSLICE:
1474     case OP_UNPACK:
1475     case OP_PACK:
1476     case OP_JOIN:
1477     case OP_LSLICE:
1478     case OP_ANONLIST:
1479     case OP_ANONHASH:
1480     case OP_SORT:
1481     case OP_REVERSE:
1482     case OP_RANGE:
1483     case OP_FLIP:
1484     case OP_FLOP:
1485     case OP_CALLER:
1486     case OP_FILENO:
1487     case OP_EOF:
1488     case OP_TELL:
1489     case OP_GETSOCKNAME:
1490     case OP_GETPEERNAME:
1491     case OP_READLINK:
1492     case OP_TELLDIR:
1493     case OP_GETPPID:
1494     case OP_GETPGRP:
1495     case OP_GETPRIORITY:
1496     case OP_TIME:
1497     case OP_TMS:
1498     case OP_LOCALTIME:
1499     case OP_GMTIME:
1500     case OP_GHBYNAME:
1501     case OP_GHBYADDR:
1502     case OP_GHOSTENT:
1503     case OP_GNBYNAME:
1504     case OP_GNBYADDR:
1505     case OP_GNETENT:
1506     case OP_GPBYNAME:
1507     case OP_GPBYNUMBER:
1508     case OP_GPROTOENT:
1509     case OP_GSBYNAME:
1510     case OP_GSBYPORT:
1511     case OP_GSERVENT:
1512     case OP_GPWNAM:
1513     case OP_GPWUID:
1514     case OP_GGRNAM:
1515     case OP_GGRGID:
1516     case OP_GETLOGIN:
1517     case OP_PROTOTYPE:
1518     case OP_RUNCV:
1519       func_ops:
1520 	if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1521 	    /* Otherwise it's "Useless use of grep iterator" */
1522 	    useless = OP_DESC(o);
1523 	break;
1524 
1525     case OP_SPLIT:
1526 	kid = cLISTOPo->op_first;
1527 	if (kid && kid->op_type == OP_PUSHRE
1528 #ifdef USE_ITHREADS
1529 		&& !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1530 #else
1531 		&& !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1532 #endif
1533 	    useless = OP_DESC(o);
1534 	break;
1535 
1536     case OP_NOT:
1537        kid = cUNOPo->op_first;
1538        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1539            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1540 	        goto func_ops;
1541        }
1542        useless = "negative pattern binding (!~)";
1543        break;
1544 
1545     case OP_SUBST:
1546 	if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1547 	    useless = "non-destructive substitution (s///r)";
1548 	break;
1549 
1550     case OP_TRANSR:
1551 	useless = "non-destructive transliteration (tr///r)";
1552 	break;
1553 
1554     case OP_RV2GV:
1555     case OP_RV2SV:
1556     case OP_RV2AV:
1557     case OP_RV2HV:
1558 	if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1559 		(!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1560 	    useless = "a variable";
1561 	break;
1562 
1563     case OP_CONST:
1564 	sv = cSVOPo_sv;
1565 	if (cSVOPo->op_private & OPpCONST_STRICT)
1566 	    no_bareword_allowed(o);
1567 	else {
1568 	    if (ckWARN(WARN_VOID)) {
1569 		/* don't warn on optimised away booleans, eg
1570 		 * use constant Foo, 5; Foo || print; */
1571 		if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1572 		    useless = NULL;
1573 		/* the constants 0 and 1 are permitted as they are
1574 		   conventionally used as dummies in constructs like
1575 		        1 while some_condition_with_side_effects;  */
1576 		else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1577 		    useless = NULL;
1578 		else if (SvPOK(sv)) {
1579                     SV * const dsv = newSVpvs("");
1580                     useless_sv
1581                         = Perl_newSVpvf(aTHX_
1582                                         "a constant (%s)",
1583                                         pv_pretty(dsv, SvPVX_const(sv),
1584                                                   SvCUR(sv), 32, NULL, NULL,
1585                                                   PERL_PV_PRETTY_DUMP
1586                                                   | PERL_PV_ESCAPE_NOCLEAR
1587                                                   | PERL_PV_ESCAPE_UNI_DETECT));
1588                     SvREFCNT_dec_NN(dsv);
1589 		}
1590 		else if (SvOK(sv)) {
1591 		    useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
1592 		}
1593 		else
1594 		    useless = "a constant (undef)";
1595 	    }
1596 	}
1597 	op_null(o);		/* don't execute or even remember it */
1598 	break;
1599 
1600     case OP_POSTINC:
1601 	o->op_type = OP_PREINC;		/* pre-increment is faster */
1602 	o->op_ppaddr = PL_ppaddr[OP_PREINC];
1603 	break;
1604 
1605     case OP_POSTDEC:
1606 	o->op_type = OP_PREDEC;		/* pre-decrement is faster */
1607 	o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1608 	break;
1609 
1610     case OP_I_POSTINC:
1611 	o->op_type = OP_I_PREINC;	/* pre-increment is faster */
1612 	o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1613 	break;
1614 
1615     case OP_I_POSTDEC:
1616 	o->op_type = OP_I_PREDEC;	/* pre-decrement is faster */
1617 	o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1618 	break;
1619 
1620     case OP_SASSIGN: {
1621 	OP *rv2gv;
1622 	UNOP *refgen, *rv2cv;
1623 	LISTOP *exlist;
1624 
1625 	if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1626 	    break;
1627 
1628 	rv2gv = ((BINOP *)o)->op_last;
1629 	if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1630 	    break;
1631 
1632 	refgen = (UNOP *)((BINOP *)o)->op_first;
1633 
1634 	if (!refgen || refgen->op_type != OP_REFGEN)
1635 	    break;
1636 
1637 	exlist = (LISTOP *)refgen->op_first;
1638 	if (!exlist || exlist->op_type != OP_NULL
1639 	    || exlist->op_targ != OP_LIST)
1640 	    break;
1641 
1642 	if (exlist->op_first->op_type != OP_PUSHMARK)
1643 	    break;
1644 
1645 	rv2cv = (UNOP*)exlist->op_last;
1646 
1647 	if (rv2cv->op_type != OP_RV2CV)
1648 	    break;
1649 
1650 	assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1651 	assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1652 	assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1653 
1654 	o->op_private |= OPpASSIGN_CV_TO_GV;
1655 	rv2gv->op_private |= OPpDONT_INIT_GV;
1656 	rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1657 
1658 	break;
1659     }
1660 
1661     case OP_AASSIGN: {
1662 	inplace_aassign(o);
1663 	break;
1664     }
1665 
1666     case OP_OR:
1667     case OP_AND:
1668 	kid = cLOGOPo->op_first;
1669 	if (kid->op_type == OP_NOT
1670 	    && (kid->op_flags & OPf_KIDS)
1671 	    && !PL_madskills) {
1672 	    if (o->op_type == OP_AND) {
1673 		o->op_type = OP_OR;
1674 		o->op_ppaddr = PL_ppaddr[OP_OR];
1675 	    } else {
1676 		o->op_type = OP_AND;
1677 		o->op_ppaddr = PL_ppaddr[OP_AND];
1678 	    }
1679 	    op_null(kid);
1680 	}
1681 
1682     case OP_DOR:
1683     case OP_COND_EXPR:
1684     case OP_ENTERGIVEN:
1685     case OP_ENTERWHEN:
1686 	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1687 	    scalarvoid(kid);
1688 	break;
1689 
1690     case OP_NULL:
1691 	if (o->op_flags & OPf_STACKED)
1692 	    break;
1693 	/* FALL THROUGH */
1694     case OP_NEXTSTATE:
1695     case OP_DBSTATE:
1696     case OP_ENTERTRY:
1697     case OP_ENTER:
1698 	if (!(o->op_flags & OPf_KIDS))
1699 	    break;
1700 	/* FALL THROUGH */
1701     case OP_SCOPE:
1702     case OP_LEAVE:
1703     case OP_LEAVETRY:
1704     case OP_LEAVELOOP:
1705     case OP_LINESEQ:
1706     case OP_LIST:
1707     case OP_LEAVEGIVEN:
1708     case OP_LEAVEWHEN:
1709 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1710 	    scalarvoid(kid);
1711 	break;
1712     case OP_ENTEREVAL:
1713 	scalarkids(o);
1714 	break;
1715     case OP_SCALAR:
1716 	return scalar(o);
1717     }
1718 
1719     if (useless_sv) {
1720         /* mortalise it, in case warnings are fatal.  */
1721         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1722                        "Useless use of %"SVf" in void context",
1723                        sv_2mortal(useless_sv));
1724     }
1725     else if (useless) {
1726        Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1727                       "Useless use of %s in void context",
1728                       useless);
1729     }
1730     return o;
1731 }
1732 
1733 static OP *
1734 S_listkids(pTHX_ OP *o)
1735 {
1736     if (o && o->op_flags & OPf_KIDS) {
1737         OP *kid;
1738 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1739 	    list(kid);
1740     }
1741     return o;
1742 }
1743 
1744 OP *
1745 Perl_list(pTHX_ OP *o)
1746 {
1747     dVAR;
1748     OP *kid;
1749 
1750     /* assumes no premature commitment */
1751     if (!o || (o->op_flags & OPf_WANT)
1752 	 || (PL_parser && PL_parser->error_count)
1753 	 || o->op_type == OP_RETURN)
1754     {
1755 	return o;
1756     }
1757 
1758     if ((o->op_private & OPpTARGET_MY)
1759 	&& (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1760     {
1761 	return o;				/* As if inside SASSIGN */
1762     }
1763 
1764     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1765 
1766     switch (o->op_type) {
1767     case OP_FLOP:
1768     case OP_REPEAT:
1769 	list(cBINOPo->op_first);
1770 	break;
1771     case OP_OR:
1772     case OP_AND:
1773     case OP_COND_EXPR:
1774 	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1775 	    list(kid);
1776 	break;
1777     default:
1778     case OP_MATCH:
1779     case OP_QR:
1780     case OP_SUBST:
1781     case OP_NULL:
1782 	if (!(o->op_flags & OPf_KIDS))
1783 	    break;
1784 	if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1785 	    list(cBINOPo->op_first);
1786 	    return gen_constant_list(o);
1787 	}
1788     case OP_LIST:
1789 	listkids(o);
1790 	break;
1791     case OP_LEAVE:
1792     case OP_LEAVETRY:
1793 	kid = cLISTOPo->op_first;
1794 	list(kid);
1795 	kid = kid->op_sibling;
1796     do_kids:
1797 	while (kid) {
1798 	    OP *sib = kid->op_sibling;
1799 	    if (sib && kid->op_type != OP_LEAVEWHEN)
1800 		scalarvoid(kid);
1801 	    else
1802 		list(kid);
1803 	    kid = sib;
1804 	}
1805 	PL_curcop = &PL_compiling;
1806 	break;
1807     case OP_SCOPE:
1808     case OP_LINESEQ:
1809 	kid = cLISTOPo->op_first;
1810 	goto do_kids;
1811     }
1812     return o;
1813 }
1814 
1815 static OP *
1816 S_scalarseq(pTHX_ OP *o)
1817 {
1818     dVAR;
1819     if (o) {
1820 	const OPCODE type = o->op_type;
1821 
1822 	if (type == OP_LINESEQ || type == OP_SCOPE ||
1823 	    type == OP_LEAVE || type == OP_LEAVETRY)
1824 	{
1825             OP *kid;
1826 	    for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1827 		if (kid->op_sibling) {
1828 		    scalarvoid(kid);
1829 		}
1830 	    }
1831 	    PL_curcop = &PL_compiling;
1832 	}
1833 	o->op_flags &= ~OPf_PARENS;
1834 	if (PL_hints & HINT_BLOCK_SCOPE)
1835 	    o->op_flags |= OPf_PARENS;
1836     }
1837     else
1838 	o = newOP(OP_STUB, 0);
1839     return o;
1840 }
1841 
1842 STATIC OP *
1843 S_modkids(pTHX_ OP *o, I32 type)
1844 {
1845     if (o && o->op_flags & OPf_KIDS) {
1846         OP *kid;
1847 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1848 	    op_lvalue(kid, type);
1849     }
1850     return o;
1851 }
1852 
1853 /*
1854 =for apidoc finalize_optree
1855 
1856 This function finalizes the optree.  Should be called directly after
1857 the complete optree is built.  It does some additional
1858 checking which can't be done in the normal ck_xxx functions and makes
1859 the tree thread-safe.
1860 
1861 =cut
1862 */
1863 void
1864 Perl_finalize_optree(pTHX_ OP* o)
1865 {
1866     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1867 
1868     ENTER;
1869     SAVEVPTR(PL_curcop);
1870 
1871     finalize_op(o);
1872 
1873     LEAVE;
1874 }
1875 
1876 STATIC void
1877 S_finalize_op(pTHX_ OP* o)
1878 {
1879     PERL_ARGS_ASSERT_FINALIZE_OP;
1880 
1881 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1882     {
1883 	/* Make sure mad ops are also thread-safe */
1884 	MADPROP *mp = o->op_madprop;
1885 	while (mp) {
1886 	    if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1887 		OP *prop_op = (OP *) mp->mad_val;
1888 		/* We only need "Relocate sv to the pad for thread safety.", but this
1889 		   easiest way to make sure it traverses everything */
1890 		if (prop_op->op_type == OP_CONST)
1891 		    cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1892 		finalize_op(prop_op);
1893 	    }
1894 	    mp = mp->mad_next;
1895 	}
1896     }
1897 #endif
1898 
1899     switch (o->op_type) {
1900     case OP_NEXTSTATE:
1901     case OP_DBSTATE:
1902 	PL_curcop = ((COP*)o);		/* for warnings */
1903 	break;
1904     case OP_EXEC:
1905 	if ( o->op_sibling
1906 	    && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1907 	    && ckWARN(WARN_EXEC))
1908 	    {
1909 		if (o->op_sibling->op_sibling) {
1910 		    const OPCODE type = o->op_sibling->op_sibling->op_type;
1911 		    if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1912 			const line_t oldline = CopLINE(PL_curcop);
1913 			CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1914 			Perl_warner(aTHX_ packWARN(WARN_EXEC),
1915 			    "Statement unlikely to be reached");
1916 			Perl_warner(aTHX_ packWARN(WARN_EXEC),
1917 			    "\t(Maybe you meant system() when you said exec()?)\n");
1918 			CopLINE_set(PL_curcop, oldline);
1919 		    }
1920 		}
1921 	    }
1922 	break;
1923 
1924     case OP_GV:
1925 	if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1926 	    GV * const gv = cGVOPo_gv;
1927 	    if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1928 		/* XXX could check prototype here instead of just carping */
1929 		SV * const sv = sv_newmortal();
1930 		gv_efullname3(sv, gv, NULL);
1931 		Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1932 		    "%"SVf"() called too early to check prototype",
1933 		    SVfARG(sv));
1934 	    }
1935 	}
1936 	break;
1937 
1938     case OP_CONST:
1939 	if (cSVOPo->op_private & OPpCONST_STRICT)
1940 	    no_bareword_allowed(o);
1941 	/* FALLTHROUGH */
1942 #ifdef USE_ITHREADS
1943     case OP_HINTSEVAL:
1944     case OP_METHOD_NAMED:
1945 	/* Relocate sv to the pad for thread safety.
1946 	 * Despite being a "constant", the SV is written to,
1947 	 * for reference counts, sv_upgrade() etc. */
1948 	if (cSVOPo->op_sv) {
1949 	    const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
1950 	    SvREFCNT_dec(PAD_SVl(ix));
1951 	    PAD_SETSV(ix, cSVOPo->op_sv);
1952 	    /* XXX I don't know how this isn't readonly already. */
1953 	    if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1954 	    cSVOPo->op_sv = NULL;
1955 	    o->op_targ = ix;
1956 	}
1957 #endif
1958 	break;
1959 
1960     case OP_HELEM: {
1961 	UNOP *rop;
1962 	SV *lexname;
1963 	GV **fields;
1964 	SVOP *key_op;
1965 	OP *kid;
1966 	bool check_fields;
1967 
1968 	if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
1969 	    break;
1970 
1971 	rop = (UNOP*)((BINOP*)o)->op_first;
1972 
1973 	goto check_keys;
1974 
1975     case OP_HSLICE:
1976 	S_scalar_slice_warning(aTHX_ o);
1977 
1978     case OP_KVHSLICE:
1979         kid = cLISTOPo->op_first->op_sibling;
1980 	if (/* I bet there's always a pushmark... */
1981 	    OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
1982 	    && OP_TYPE_ISNT_NN(kid, OP_CONST))
1983         {
1984 	    break;
1985         }
1986 
1987 	key_op = (SVOP*)(kid->op_type == OP_CONST
1988 				? kid
1989 				: kLISTOP->op_first->op_sibling);
1990 
1991 	rop = (UNOP*)((LISTOP*)o)->op_last;
1992 
1993       check_keys:
1994 	if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
1995 	    rop = NULL;
1996 	else if (rop->op_first->op_type == OP_PADSV)
1997 	    /* @$hash{qw(keys here)} */
1998 	    rop = (UNOP*)rop->op_first;
1999 	else {
2000 	    /* @{$hash}{qw(keys here)} */
2001 	    if (rop->op_first->op_type == OP_SCOPE
2002 		&& cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2003 		{
2004 		    rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2005 		}
2006 	    else
2007 		rop = NULL;
2008 	}
2009 
2010         lexname = NULL; /* just to silence compiler warnings */
2011         fields  = NULL; /* just to silence compiler warnings */
2012 
2013 	check_fields =
2014 	    rop
2015 	 && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2016 	     SvPAD_TYPED(lexname))
2017 	 && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2018 	 && isGV(*fields) && GvHV(*fields);
2019 	for (; key_op;
2020 	     key_op = (SVOP*)key_op->op_sibling) {
2021 	    SV **svp, *sv;
2022 	    if (key_op->op_type != OP_CONST)
2023 		continue;
2024 	    svp = cSVOPx_svp(key_op);
2025 
2026 	    /* Make the CONST have a shared SV */
2027 	    if ((!SvIsCOW_shared_hash(sv = *svp))
2028 	     && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2029 		SSize_t keylen;
2030 		const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2031 		SV *nsv = newSVpvn_share(key,
2032 					 SvUTF8(sv) ? -keylen : keylen,	0);
2033 		SvREFCNT_dec_NN(sv);
2034 		*svp = nsv;
2035 	    }
2036 
2037 	    if (check_fields
2038 	     && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2039 		Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
2040 			   "in variable %"SVf" of type %"HEKf,
2041 		      SVfARG(*svp), SVfARG(lexname),
2042                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2043 	    }
2044 	}
2045 	break;
2046     }
2047     case OP_ASLICE:
2048 	S_scalar_slice_warning(aTHX_ o);
2049 	break;
2050 
2051     case OP_SUBST: {
2052 	if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2053 	    finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2054 	break;
2055     }
2056     default:
2057 	break;
2058     }
2059 
2060     if (o->op_flags & OPf_KIDS) {
2061 	OP *kid;
2062 	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2063 	    finalize_op(kid);
2064     }
2065 }
2066 
2067 /*
2068 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2069 
2070 Propagate lvalue ("modifiable") context to an op and its children.
2071 I<type> represents the context type, roughly based on the type of op that
2072 would do the modifying, although C<local()> is represented by OP_NULL,
2073 because it has no op type of its own (it is signalled by a flag on
2074 the lvalue op).
2075 
2076 This function detects things that can't be modified, such as C<$x+1>, and
2077 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2078 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2079 
2080 It also flags things that need to behave specially in an lvalue context,
2081 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2082 
2083 =cut
2084 */
2085 
2086 static bool
2087 S_vivifies(const OPCODE type)
2088 {
2089     switch(type) {
2090     case OP_RV2AV:     case   OP_ASLICE:
2091     case OP_RV2HV:     case OP_KVASLICE:
2092     case OP_RV2SV:     case   OP_HSLICE:
2093     case OP_AELEMFAST: case OP_KVHSLICE:
2094     case OP_HELEM:
2095     case OP_AELEM:
2096 	return 1;
2097     }
2098     return 0;
2099 }
2100 
2101 OP *
2102 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2103 {
2104     dVAR;
2105     OP *kid;
2106     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2107     int localize = -1;
2108 
2109     if (!o || (PL_parser && PL_parser->error_count))
2110 	return o;
2111 
2112     if ((o->op_private & OPpTARGET_MY)
2113 	&& (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2114     {
2115 	return o;
2116     }
2117 
2118     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2119 
2120     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2121 
2122     switch (o->op_type) {
2123     case OP_UNDEF:
2124 	PL_modcount++;
2125 	return o;
2126     case OP_STUB:
2127 	if ((o->op_flags & OPf_PARENS) || PL_madskills)
2128 	    break;
2129 	goto nomod;
2130     case OP_ENTERSUB:
2131 	if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2132 	    !(o->op_flags & OPf_STACKED)) {
2133 	    o->op_type = OP_RV2CV;		/* entersub => rv2cv */
2134 	    /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2135 	       poses, so we need it clear.  */
2136 	    o->op_private &= ~1;
2137 	    o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2138 	    assert(cUNOPo->op_first->op_type == OP_NULL);
2139 	    op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2140 	    break;
2141 	}
2142 	else {				/* lvalue subroutine call */
2143 	    o->op_private |= OPpLVAL_INTRO
2144 	                   |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2145 	    PL_modcount = RETURN_UNLIMITED_NUMBER;
2146 	    if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2147 		/* Potential lvalue context: */
2148 		o->op_private |= OPpENTERSUB_INARGS;
2149 		break;
2150 	    }
2151 	    else {                      /* Compile-time error message: */
2152 		OP *kid = cUNOPo->op_first;
2153 		CV *cv;
2154 
2155 		if (kid->op_type != OP_PUSHMARK) {
2156 		    if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2157 			Perl_croak(aTHX_
2158 				"panic: unexpected lvalue entersub "
2159 				"args: type/targ %ld:%"UVuf,
2160 				(long)kid->op_type, (UV)kid->op_targ);
2161 		    kid = kLISTOP->op_first;
2162 		}
2163 		while (kid->op_sibling)
2164 		    kid = kid->op_sibling;
2165 		if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2166 		    break;	/* Postpone until runtime */
2167 		}
2168 
2169 		kid = kUNOP->op_first;
2170 		if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2171 		    kid = kUNOP->op_first;
2172 		if (kid->op_type == OP_NULL)
2173 		    Perl_croak(aTHX_
2174 			       "Unexpected constant lvalue entersub "
2175 			       "entry via type/targ %ld:%"UVuf,
2176 			       (long)kid->op_type, (UV)kid->op_targ);
2177 		if (kid->op_type != OP_GV) {
2178 		    break;
2179 		}
2180 
2181 		cv = GvCV(kGVOP_gv);
2182 		if (!cv)
2183 		    break;
2184 		if (CvLVALUE(cv))
2185 		    break;
2186 	    }
2187 	}
2188 	/* FALL THROUGH */
2189     default:
2190       nomod:
2191 	if (flags & OP_LVALUE_NO_CROAK) return NULL;
2192 	/* grep, foreach, subcalls, refgen */
2193 	if (type == OP_GREPSTART || type == OP_ENTERSUB
2194 	 || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2195 	    break;
2196 	yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2197 		     (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2198 		      ? "do block"
2199 		      : (o->op_type == OP_ENTERSUB
2200 			? "non-lvalue subroutine call"
2201 			: OP_DESC(o))),
2202 		     type ? PL_op_desc[type] : "local"));
2203 	return o;
2204 
2205     case OP_PREINC:
2206     case OP_PREDEC:
2207     case OP_POW:
2208     case OP_MULTIPLY:
2209     case OP_DIVIDE:
2210     case OP_MODULO:
2211     case OP_REPEAT:
2212     case OP_ADD:
2213     case OP_SUBTRACT:
2214     case OP_CONCAT:
2215     case OP_LEFT_SHIFT:
2216     case OP_RIGHT_SHIFT:
2217     case OP_BIT_AND:
2218     case OP_BIT_XOR:
2219     case OP_BIT_OR:
2220     case OP_I_MULTIPLY:
2221     case OP_I_DIVIDE:
2222     case OP_I_MODULO:
2223     case OP_I_ADD:
2224     case OP_I_SUBTRACT:
2225 	if (!(o->op_flags & OPf_STACKED))
2226 	    goto nomod;
2227 	PL_modcount++;
2228 	break;
2229 
2230     case OP_COND_EXPR:
2231 	localize = 1;
2232 	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2233 	    op_lvalue(kid, type);
2234 	break;
2235 
2236     case OP_RV2AV:
2237     case OP_RV2HV:
2238 	if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2239            PL_modcount = RETURN_UNLIMITED_NUMBER;
2240 	    return o;		/* Treat \(@foo) like ordinary list. */
2241 	}
2242 	/* FALL THROUGH */
2243     case OP_RV2GV:
2244 	if (scalar_mod_type(o, type))
2245 	    goto nomod;
2246 	ref(cUNOPo->op_first, o->op_type);
2247 	/* FALL THROUGH */
2248     case OP_ASLICE:
2249     case OP_HSLICE:
2250 	localize = 1;
2251 	/* FALL THROUGH */
2252     case OP_AASSIGN:
2253 	/* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2254 	if (type == OP_LEAVESUBLV && (
2255 		(o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2256 	     || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2257 	   ))
2258 	    o->op_private |= OPpMAYBE_LVSUB;
2259 	/* FALL THROUGH */
2260     case OP_NEXTSTATE:
2261     case OP_DBSTATE:
2262        PL_modcount = RETURN_UNLIMITED_NUMBER;
2263 	break;
2264     case OP_KVHSLICE:
2265     case OP_KVASLICE:
2266 	if (type == OP_LEAVESUBLV)
2267 	    o->op_private |= OPpMAYBE_LVSUB;
2268         goto nomod;
2269     case OP_AV2ARYLEN:
2270 	PL_hints |= HINT_BLOCK_SCOPE;
2271 	if (type == OP_LEAVESUBLV)
2272 	    o->op_private |= OPpMAYBE_LVSUB;
2273 	PL_modcount++;
2274 	break;
2275     case OP_RV2SV:
2276 	ref(cUNOPo->op_first, o->op_type);
2277 	localize = 1;
2278 	/* FALL THROUGH */
2279     case OP_GV:
2280 	PL_hints |= HINT_BLOCK_SCOPE;
2281     case OP_SASSIGN:
2282     case OP_ANDASSIGN:
2283     case OP_ORASSIGN:
2284     case OP_DORASSIGN:
2285 	PL_modcount++;
2286 	break;
2287 
2288     case OP_AELEMFAST:
2289     case OP_AELEMFAST_LEX:
2290 	localize = -1;
2291 	PL_modcount++;
2292 	break;
2293 
2294     case OP_PADAV:
2295     case OP_PADHV:
2296        PL_modcount = RETURN_UNLIMITED_NUMBER;
2297 	if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2298 	    return o;		/* Treat \(@foo) like ordinary list. */
2299 	if (scalar_mod_type(o, type))
2300 	    goto nomod;
2301 	if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2302 	  && type == OP_LEAVESUBLV)
2303 	    o->op_private |= OPpMAYBE_LVSUB;
2304 	/* FALL THROUGH */
2305     case OP_PADSV:
2306 	PL_modcount++;
2307 	if (!type) /* local() */
2308 	    Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2309 		 PAD_COMPNAME_SV(o->op_targ));
2310 	break;
2311 
2312     case OP_PUSHMARK:
2313 	localize = 0;
2314 	break;
2315 
2316     case OP_KEYS:
2317     case OP_RKEYS:
2318 	if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2319 	    goto nomod;
2320 	goto lvalue_func;
2321     case OP_SUBSTR:
2322 	if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2323 	    goto nomod;
2324 	/* FALL THROUGH */
2325     case OP_POS:
2326     case OP_VEC:
2327       lvalue_func:
2328 	if (type == OP_LEAVESUBLV)
2329 	    o->op_private |= OPpMAYBE_LVSUB;
2330 	if (o->op_flags & OPf_KIDS)
2331 	    op_lvalue(cBINOPo->op_first->op_sibling, type);
2332 	break;
2333 
2334     case OP_AELEM:
2335     case OP_HELEM:
2336 	ref(cBINOPo->op_first, o->op_type);
2337 	if (type == OP_ENTERSUB &&
2338 	     !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2339 	    o->op_private |= OPpLVAL_DEFER;
2340 	if (type == OP_LEAVESUBLV)
2341 	    o->op_private |= OPpMAYBE_LVSUB;
2342 	localize = 1;
2343 	PL_modcount++;
2344 	break;
2345 
2346     case OP_LEAVE:
2347     case OP_LEAVELOOP:
2348 	o->op_private |= OPpLVALUE;
2349     case OP_SCOPE:
2350     case OP_ENTER:
2351     case OP_LINESEQ:
2352 	localize = 0;
2353 	if (o->op_flags & OPf_KIDS)
2354 	    op_lvalue(cLISTOPo->op_last, type);
2355 	break;
2356 
2357     case OP_NULL:
2358 	localize = 0;
2359 	if (o->op_flags & OPf_SPECIAL)		/* do BLOCK */
2360 	    goto nomod;
2361 	else if (!(o->op_flags & OPf_KIDS))
2362 	    break;
2363 	if (o->op_targ != OP_LIST) {
2364 	    op_lvalue(cBINOPo->op_first, type);
2365 	    break;
2366 	}
2367 	/* FALL THROUGH */
2368     case OP_LIST:
2369 	localize = 0;
2370 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2371 	    /* elements might be in void context because the list is
2372 	       in scalar context or because they are attribute sub calls */
2373 	    if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2374 		op_lvalue(kid, type);
2375 	break;
2376 
2377     case OP_RETURN:
2378 	if (type != OP_LEAVESUBLV)
2379 	    goto nomod;
2380 	break; /* op_lvalue()ing was handled by ck_return() */
2381 
2382     case OP_COREARGS:
2383 	return o;
2384 
2385     case OP_AND:
2386     case OP_OR:
2387 	if (type == OP_LEAVESUBLV
2388 	 || !S_vivifies(cLOGOPo->op_first->op_type))
2389 	    op_lvalue(cLOGOPo->op_first, type);
2390 	if (type == OP_LEAVESUBLV
2391 	 || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type))
2392 	    op_lvalue(cLOGOPo->op_first->op_sibling, type);
2393 	goto nomod;
2394     }
2395 
2396     /* [20011101.069] File test operators interpret OPf_REF to mean that
2397        their argument is a filehandle; thus \stat(".") should not set
2398        it. AMS 20011102 */
2399     if (type == OP_REFGEN &&
2400         PL_check[o->op_type] == Perl_ck_ftst)
2401         return o;
2402 
2403     if (type != OP_LEAVESUBLV)
2404         o->op_flags |= OPf_MOD;
2405 
2406     if (type == OP_AASSIGN || type == OP_SASSIGN)
2407 	o->op_flags |= OPf_SPECIAL|OPf_REF;
2408     else if (!type) { /* local() */
2409 	switch (localize) {
2410 	case 1:
2411 	    o->op_private |= OPpLVAL_INTRO;
2412 	    o->op_flags &= ~OPf_SPECIAL;
2413 	    PL_hints |= HINT_BLOCK_SCOPE;
2414 	    break;
2415 	case 0:
2416 	    break;
2417 	case -1:
2418 	    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2419 			   "Useless localization of %s", OP_DESC(o));
2420 	}
2421     }
2422     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2423              && type != OP_LEAVESUBLV)
2424 	o->op_flags |= OPf_REF;
2425     return o;
2426 }
2427 
2428 STATIC bool
2429 S_scalar_mod_type(const OP *o, I32 type)
2430 {
2431     switch (type) {
2432     case OP_POS:
2433     case OP_SASSIGN:
2434 	if (o && o->op_type == OP_RV2GV)
2435 	    return FALSE;
2436 	/* FALL THROUGH */
2437     case OP_PREINC:
2438     case OP_PREDEC:
2439     case OP_POSTINC:
2440     case OP_POSTDEC:
2441     case OP_I_PREINC:
2442     case OP_I_PREDEC:
2443     case OP_I_POSTINC:
2444     case OP_I_POSTDEC:
2445     case OP_POW:
2446     case OP_MULTIPLY:
2447     case OP_DIVIDE:
2448     case OP_MODULO:
2449     case OP_REPEAT:
2450     case OP_ADD:
2451     case OP_SUBTRACT:
2452     case OP_I_MULTIPLY:
2453     case OP_I_DIVIDE:
2454     case OP_I_MODULO:
2455     case OP_I_ADD:
2456     case OP_I_SUBTRACT:
2457     case OP_LEFT_SHIFT:
2458     case OP_RIGHT_SHIFT:
2459     case OP_BIT_AND:
2460     case OP_BIT_XOR:
2461     case OP_BIT_OR:
2462     case OP_CONCAT:
2463     case OP_SUBST:
2464     case OP_TRANS:
2465     case OP_TRANSR:
2466     case OP_READ:
2467     case OP_SYSREAD:
2468     case OP_RECV:
2469     case OP_ANDASSIGN:
2470     case OP_ORASSIGN:
2471     case OP_DORASSIGN:
2472 	return TRUE;
2473     default:
2474 	return FALSE;
2475     }
2476 }
2477 
2478 STATIC bool
2479 S_is_handle_constructor(const OP *o, I32 numargs)
2480 {
2481     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2482 
2483     switch (o->op_type) {
2484     case OP_PIPE_OP:
2485     case OP_SOCKPAIR:
2486 	if (numargs == 2)
2487 	    return TRUE;
2488 	/* FALL THROUGH */
2489     case OP_SYSOPEN:
2490     case OP_OPEN:
2491     case OP_SELECT:		/* XXX c.f. SelectSaver.pm */
2492     case OP_SOCKET:
2493     case OP_OPEN_DIR:
2494     case OP_ACCEPT:
2495 	if (numargs == 1)
2496 	    return TRUE;
2497 	/* FALLTHROUGH */
2498     default:
2499 	return FALSE;
2500     }
2501 }
2502 
2503 static OP *
2504 S_refkids(pTHX_ OP *o, I32 type)
2505 {
2506     if (o && o->op_flags & OPf_KIDS) {
2507         OP *kid;
2508 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2509 	    ref(kid, type);
2510     }
2511     return o;
2512 }
2513 
2514 OP *
2515 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2516 {
2517     dVAR;
2518     OP *kid;
2519 
2520     PERL_ARGS_ASSERT_DOREF;
2521 
2522     if (!o || (PL_parser && PL_parser->error_count))
2523 	return o;
2524 
2525     switch (o->op_type) {
2526     case OP_ENTERSUB:
2527 	if ((type == OP_EXISTS || type == OP_DEFINED) &&
2528 	    !(o->op_flags & OPf_STACKED)) {
2529 	    o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2530 	    o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2531 	    assert(cUNOPo->op_first->op_type == OP_NULL);
2532 	    op_null(((LISTOP*)cUNOPo->op_first)->op_first);	/* disable pushmark */
2533 	    o->op_flags |= OPf_SPECIAL;
2534 	    o->op_private &= ~1;
2535 	}
2536 	else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2537 	    o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2538 			      : type == OP_RV2HV ? OPpDEREF_HV
2539 			      : OPpDEREF_SV);
2540 	    o->op_flags |= OPf_MOD;
2541 	}
2542 
2543 	break;
2544 
2545     case OP_COND_EXPR:
2546 	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2547 	    doref(kid, type, set_op_ref);
2548 	break;
2549     case OP_RV2SV:
2550 	if (type == OP_DEFINED)
2551 	    o->op_flags |= OPf_SPECIAL;		/* don't create GV */
2552 	doref(cUNOPo->op_first, o->op_type, set_op_ref);
2553 	/* FALL THROUGH */
2554     case OP_PADSV:
2555 	if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2556 	    o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2557 			      : type == OP_RV2HV ? OPpDEREF_HV
2558 			      : OPpDEREF_SV);
2559 	    o->op_flags |= OPf_MOD;
2560 	}
2561 	break;
2562 
2563     case OP_RV2AV:
2564     case OP_RV2HV:
2565 	if (set_op_ref)
2566 	    o->op_flags |= OPf_REF;
2567 	/* FALL THROUGH */
2568     case OP_RV2GV:
2569 	if (type == OP_DEFINED)
2570 	    o->op_flags |= OPf_SPECIAL;		/* don't create GV */
2571 	doref(cUNOPo->op_first, o->op_type, set_op_ref);
2572 	break;
2573 
2574     case OP_PADAV:
2575     case OP_PADHV:
2576 	if (set_op_ref)
2577 	    o->op_flags |= OPf_REF;
2578 	break;
2579 
2580     case OP_SCALAR:
2581     case OP_NULL:
2582 	if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2583 	    break;
2584 	doref(cBINOPo->op_first, type, set_op_ref);
2585 	break;
2586     case OP_AELEM:
2587     case OP_HELEM:
2588 	doref(cBINOPo->op_first, o->op_type, set_op_ref);
2589 	if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2590 	    o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2591 			      : type == OP_RV2HV ? OPpDEREF_HV
2592 			      : OPpDEREF_SV);
2593 	    o->op_flags |= OPf_MOD;
2594 	}
2595 	break;
2596 
2597     case OP_SCOPE:
2598     case OP_LEAVE:
2599 	set_op_ref = FALSE;
2600 	/* FALL THROUGH */
2601     case OP_ENTER:
2602     case OP_LIST:
2603 	if (!(o->op_flags & OPf_KIDS))
2604 	    break;
2605 	doref(cLISTOPo->op_last, type, set_op_ref);
2606 	break;
2607     default:
2608 	break;
2609     }
2610     return scalar(o);
2611 
2612 }
2613 
2614 STATIC OP *
2615 S_dup_attrlist(pTHX_ OP *o)
2616 {
2617     dVAR;
2618     OP *rop;
2619 
2620     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2621 
2622     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2623      * where the first kid is OP_PUSHMARK and the remaining ones
2624      * are OP_CONST.  We need to push the OP_CONST values.
2625      */
2626     if (o->op_type == OP_CONST)
2627 	rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2628 #ifdef PERL_MAD
2629     else if (o->op_type == OP_NULL)
2630 	rop = NULL;
2631 #endif
2632     else {
2633 	assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2634 	rop = NULL;
2635 	for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2636 	    if (o->op_type == OP_CONST)
2637 		rop = op_append_elem(OP_LIST, rop,
2638 				  newSVOP(OP_CONST, o->op_flags,
2639 					  SvREFCNT_inc_NN(cSVOPo->op_sv)));
2640 	}
2641     }
2642     return rop;
2643 }
2644 
2645 STATIC void
2646 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2647 {
2648     dVAR;
2649     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2650 
2651     PERL_ARGS_ASSERT_APPLY_ATTRS;
2652 
2653     /* fake up C<use attributes $pkg,$rv,@attrs> */
2654 
2655 #define ATTRSMODULE "attributes"
2656 #define ATTRSMODULE_PM "attributes.pm"
2657 
2658     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2659 			 newSVpvs(ATTRSMODULE),
2660 			 NULL,
2661 			 op_prepend_elem(OP_LIST,
2662 				      newSVOP(OP_CONST, 0, stashsv),
2663 				      op_prepend_elem(OP_LIST,
2664 						   newSVOP(OP_CONST, 0,
2665 							   newRV(target)),
2666 						   dup_attrlist(attrs))));
2667 }
2668 
2669 STATIC void
2670 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2671 {
2672     dVAR;
2673     OP *pack, *imop, *arg;
2674     SV *meth, *stashsv, **svp;
2675 
2676     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2677 
2678     if (!attrs)
2679 	return;
2680 
2681     assert(target->op_type == OP_PADSV ||
2682 	   target->op_type == OP_PADHV ||
2683 	   target->op_type == OP_PADAV);
2684 
2685     /* Ensure that attributes.pm is loaded. */
2686     /* Don't force the C<use> if we don't need it. */
2687     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2688     if (svp && *svp != &PL_sv_undef)
2689 	NOOP;	/* already in %INC */
2690     else
2691 	Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2692 			       newSVpvs(ATTRSMODULE), NULL);
2693 
2694     /* Need package name for method call. */
2695     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2696 
2697     /* Build up the real arg-list. */
2698     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2699 
2700     arg = newOP(OP_PADSV, 0);
2701     arg->op_targ = target->op_targ;
2702     arg = op_prepend_elem(OP_LIST,
2703 		       newSVOP(OP_CONST, 0, stashsv),
2704 		       op_prepend_elem(OP_LIST,
2705 				    newUNOP(OP_REFGEN, 0,
2706 					    op_lvalue(arg, OP_REFGEN)),
2707 				    dup_attrlist(attrs)));
2708 
2709     /* Fake up a method call to import */
2710     meth = newSVpvs_share("import");
2711     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2712 		   op_append_elem(OP_LIST,
2713 			       op_prepend_elem(OP_LIST, pack, list(arg)),
2714 			       newSVOP(OP_METHOD_NAMED, 0, meth)));
2715 
2716     /* Combine the ops. */
2717     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2718 }
2719 
2720 /*
2721 =notfor apidoc apply_attrs_string
2722 
2723 Attempts to apply a list of attributes specified by the C<attrstr> and
2724 C<len> arguments to the subroutine identified by the C<cv> argument which
2725 is expected to be associated with the package identified by the C<stashpv>
2726 argument (see L<attributes>).  It gets this wrong, though, in that it
2727 does not correctly identify the boundaries of the individual attribute
2728 specifications within C<attrstr>.  This is not really intended for the
2729 public API, but has to be listed here for systems such as AIX which
2730 need an explicit export list for symbols.  (It's called from XS code
2731 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2732 to respect attribute syntax properly would be welcome.
2733 
2734 =cut
2735 */
2736 
2737 void
2738 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2739                         const char *attrstr, STRLEN len)
2740 {
2741     OP *attrs = NULL;
2742 
2743     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2744 
2745     if (!len) {
2746         len = strlen(attrstr);
2747     }
2748 
2749     while (len) {
2750         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2751         if (len) {
2752             const char * const sstr = attrstr;
2753             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2754             attrs = op_append_elem(OP_LIST, attrs,
2755                                 newSVOP(OP_CONST, 0,
2756                                         newSVpvn(sstr, attrstr-sstr)));
2757         }
2758     }
2759 
2760     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2761 		     newSVpvs(ATTRSMODULE),
2762                      NULL, op_prepend_elem(OP_LIST,
2763 				  newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2764 				  op_prepend_elem(OP_LIST,
2765 					       newSVOP(OP_CONST, 0,
2766 						       newRV(MUTABLE_SV(cv))),
2767                                                attrs)));
2768 }
2769 
2770 STATIC void
2771 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2772 {
2773     OP *new_proto = NULL;
2774     STRLEN pvlen;
2775     char *pv;
2776     OP *o;
2777 
2778     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2779 
2780     if (!*attrs)
2781         return;
2782 
2783     o = *attrs;
2784     if (o->op_type == OP_CONST) {
2785         pv = SvPV(cSVOPo_sv, pvlen);
2786         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2787             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2788             SV ** const tmpo = cSVOPx_svp(o);
2789             SvREFCNT_dec(cSVOPo_sv);
2790             *tmpo = tmpsv;
2791             new_proto = o;
2792             *attrs = NULL;
2793         }
2794     } else if (o->op_type == OP_LIST) {
2795         OP * lasto = NULL;
2796         assert(o->op_flags & OPf_KIDS);
2797         assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
2798         /* Counting on the first op to hit the lasto = o line */
2799         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2800             if (o->op_type == OP_CONST) {
2801                 pv = SvPV(cSVOPo_sv, pvlen);
2802                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2803                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2804                     SV ** const tmpo = cSVOPx_svp(o);
2805                     SvREFCNT_dec(cSVOPo_sv);
2806                     *tmpo = tmpsv;
2807                     if (new_proto && ckWARN(WARN_MISC)) {
2808                         STRLEN new_len;
2809                         const char * newp = SvPV(cSVOPo_sv, new_len);
2810                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2811                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
2812                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
2813                         op_free(new_proto);
2814                     }
2815                     else if (new_proto)
2816                         op_free(new_proto);
2817                     new_proto = o;
2818                     lasto->op_sibling = o->op_sibling;
2819                     continue;
2820                 }
2821             }
2822             lasto = o;
2823         }
2824         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
2825            would get pulled in with no real need */
2826         if (!cLISTOPx(*attrs)->op_first->op_sibling) {
2827             op_free(*attrs);
2828             *attrs = NULL;
2829         }
2830     }
2831 
2832     if (new_proto) {
2833         SV *svname;
2834         if (isGV(name)) {
2835             svname = sv_newmortal();
2836             gv_efullname3(svname, name, NULL);
2837         }
2838         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
2839             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
2840         else
2841             svname = (SV *)name;
2842         if (ckWARN(WARN_ILLEGALPROTO))
2843             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
2844         if (*proto && ckWARN(WARN_PROTOTYPE)) {
2845             STRLEN old_len, new_len;
2846             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
2847             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
2848 
2849             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2850                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
2851                 " in %"SVf,
2852                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
2853                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
2854                 SVfARG(svname));
2855         }
2856         if (*proto)
2857             op_free(*proto);
2858         *proto = new_proto;
2859     }
2860 }
2861 
2862 static void
2863 S_cant_declare(pTHX_ OP *o)
2864 {
2865     if (o->op_type == OP_NULL
2866      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
2867         o = cUNOPo->op_first;
2868     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2869                              o->op_type == OP_NULL
2870                                && o->op_flags & OPf_SPECIAL
2871                                  ? "do block"
2872                                  : OP_DESC(o),
2873                              PL_parser->in_my == KEY_our   ? "our"   :
2874                              PL_parser->in_my == KEY_state ? "state" :
2875                                                              "my"));
2876 }
2877 
2878 STATIC OP *
2879 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2880 {
2881     dVAR;
2882     I32 type;
2883     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2884 
2885     PERL_ARGS_ASSERT_MY_KID;
2886 
2887     if (!o || (PL_parser && PL_parser->error_count))
2888 	return o;
2889 
2890     type = o->op_type;
2891     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2892 	(void)my_kid(cUNOPo->op_first, attrs, imopsp);
2893 	return o;
2894     }
2895 
2896     if (type == OP_LIST) {
2897         OP *kid;
2898 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2899 	    my_kid(kid, attrs, imopsp);
2900 	return o;
2901     } else if (type == OP_UNDEF || type == OP_STUB) {
2902 	return o;
2903     } else if (type == OP_RV2SV ||	/* "our" declaration */
2904 	       type == OP_RV2AV ||
2905 	       type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2906 	if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2907 	    S_cant_declare(aTHX_ o);
2908 	} else if (attrs) {
2909 	    GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2910 	    PL_parser->in_my = FALSE;
2911 	    PL_parser->in_my_stash = NULL;
2912 	    apply_attrs(GvSTASH(gv),
2913 			(type == OP_RV2SV ? GvSV(gv) :
2914 			 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2915 			 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2916 			attrs);
2917 	}
2918 	o->op_private |= OPpOUR_INTRO;
2919 	return o;
2920     }
2921     else if (type != OP_PADSV &&
2922 	     type != OP_PADAV &&
2923 	     type != OP_PADHV &&
2924 	     type != OP_PUSHMARK)
2925     {
2926 	S_cant_declare(aTHX_ o);
2927 	return o;
2928     }
2929     else if (attrs && type != OP_PUSHMARK) {
2930 	HV *stash;
2931 
2932 	PL_parser->in_my = FALSE;
2933 	PL_parser->in_my_stash = NULL;
2934 
2935 	/* check for C<my Dog $spot> when deciding package */
2936 	stash = PAD_COMPNAME_TYPE(o->op_targ);
2937 	if (!stash)
2938 	    stash = PL_curstash;
2939 	apply_attrs_my(stash, o, attrs, imopsp);
2940     }
2941     o->op_flags |= OPf_MOD;
2942     o->op_private |= OPpLVAL_INTRO;
2943     if (stately)
2944 	o->op_private |= OPpPAD_STATE;
2945     return o;
2946 }
2947 
2948 OP *
2949 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2950 {
2951     dVAR;
2952     OP *rops;
2953     int maybe_scalar = 0;
2954 
2955     PERL_ARGS_ASSERT_MY_ATTRS;
2956 
2957 /* [perl #17376]: this appears to be premature, and results in code such as
2958    C< our(%x); > executing in list mode rather than void mode */
2959 #if 0
2960     if (o->op_flags & OPf_PARENS)
2961 	list(o);
2962     else
2963 	maybe_scalar = 1;
2964 #else
2965     maybe_scalar = 1;
2966 #endif
2967     if (attrs)
2968 	SAVEFREEOP(attrs);
2969     rops = NULL;
2970     o = my_kid(o, attrs, &rops);
2971     if (rops) {
2972 	if (maybe_scalar && o->op_type == OP_PADSV) {
2973 	    o = scalar(op_append_list(OP_LIST, rops, o));
2974 	    o->op_private |= OPpLVAL_INTRO;
2975 	}
2976 	else {
2977 	    /* The listop in rops might have a pushmark at the beginning,
2978 	       which will mess up list assignment. */
2979 	    LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2980 	    if (rops->op_type == OP_LIST &&
2981 	        lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2982 	    {
2983 		OP * const pushmark = lrops->op_first;
2984 		lrops->op_first = pushmark->op_sibling;
2985 		op_free(pushmark);
2986 	    }
2987 	    o = op_append_list(OP_LIST, o, rops);
2988 	}
2989     }
2990     PL_parser->in_my = FALSE;
2991     PL_parser->in_my_stash = NULL;
2992     return o;
2993 }
2994 
2995 OP *
2996 Perl_sawparens(pTHX_ OP *o)
2997 {
2998     PERL_UNUSED_CONTEXT;
2999     if (o)
3000 	o->op_flags |= OPf_PARENS;
3001     return o;
3002 }
3003 
3004 OP *
3005 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3006 {
3007     OP *o;
3008     bool ismatchop = 0;
3009     const OPCODE ltype = left->op_type;
3010     const OPCODE rtype = right->op_type;
3011 
3012     PERL_ARGS_ASSERT_BIND_MATCH;
3013 
3014     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3015 	  || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3016     {
3017       const char * const desc
3018 	  = PL_op_desc[(
3019 		          rtype == OP_SUBST || rtype == OP_TRANS
3020 		       || rtype == OP_TRANSR
3021 		       )
3022 		       ? (int)rtype : OP_MATCH];
3023       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3024       SV * const name =
3025 	S_op_varname(aTHX_ left);
3026       if (name)
3027 	Perl_warner(aTHX_ packWARN(WARN_MISC),
3028              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3029              desc, name, name);
3030       else {
3031 	const char * const sample = (isary
3032 	     ? "@array" : "%hash");
3033 	Perl_warner(aTHX_ packWARN(WARN_MISC),
3034              "Applying %s to %s will act on scalar(%s)",
3035              desc, sample, sample);
3036       }
3037     }
3038 
3039     if (rtype == OP_CONST &&
3040 	cSVOPx(right)->op_private & OPpCONST_BARE &&
3041 	cSVOPx(right)->op_private & OPpCONST_STRICT)
3042     {
3043 	no_bareword_allowed(right);
3044     }
3045 
3046     /* !~ doesn't make sense with /r, so error on it for now */
3047     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3048 	type == OP_NOT)
3049 	/* diag_listed_as: Using !~ with %s doesn't make sense */
3050 	yyerror("Using !~ with s///r doesn't make sense");
3051     if (rtype == OP_TRANSR && type == OP_NOT)
3052 	/* diag_listed_as: Using !~ with %s doesn't make sense */
3053 	yyerror("Using !~ with tr///r doesn't make sense");
3054 
3055     ismatchop = (rtype == OP_MATCH ||
3056 		 rtype == OP_SUBST ||
3057 		 rtype == OP_TRANS || rtype == OP_TRANSR)
3058 	     && !(right->op_flags & OPf_SPECIAL);
3059     if (ismatchop && right->op_private & OPpTARGET_MY) {
3060 	right->op_targ = 0;
3061 	right->op_private &= ~OPpTARGET_MY;
3062     }
3063     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3064 	OP *newleft;
3065 
3066 	right->op_flags |= OPf_STACKED;
3067 	if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3068             ! (rtype == OP_TRANS &&
3069                right->op_private & OPpTRANS_IDENTICAL) &&
3070 	    ! (rtype == OP_SUBST &&
3071 	       (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3072 	    newleft = op_lvalue(left, rtype);
3073 	else
3074 	    newleft = left;
3075 	if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3076 	    o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3077 	else
3078 	    o = op_prepend_elem(rtype, scalar(newleft), right);
3079 	if (type == OP_NOT)
3080 	    return newUNOP(OP_NOT, 0, scalar(o));
3081 	return o;
3082     }
3083     else
3084 	return bind_match(type, left,
3085 		pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3086 }
3087 
3088 OP *
3089 Perl_invert(pTHX_ OP *o)
3090 {
3091     if (!o)
3092 	return NULL;
3093     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3094 }
3095 
3096 /*
3097 =for apidoc Amx|OP *|op_scope|OP *o
3098 
3099 Wraps up an op tree with some additional ops so that at runtime a dynamic
3100 scope will be created.  The original ops run in the new dynamic scope,
3101 and then, provided that they exit normally, the scope will be unwound.
3102 The additional ops used to create and unwind the dynamic scope will
3103 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3104 instead if the ops are simple enough to not need the full dynamic scope
3105 structure.
3106 
3107 =cut
3108 */
3109 
3110 OP *
3111 Perl_op_scope(pTHX_ OP *o)
3112 {
3113     dVAR;
3114     if (o) {
3115 	if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3116 	    o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3117 	    o->op_type = OP_LEAVE;
3118 	    o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3119 	}
3120 	else if (o->op_type == OP_LINESEQ) {
3121 	    OP *kid;
3122 	    o->op_type = OP_SCOPE;
3123 	    o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3124 	    kid = ((LISTOP*)o)->op_first;
3125 	    if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3126 		op_null(kid);
3127 
3128 		/* The following deals with things like 'do {1 for 1}' */
3129 		kid = kid->op_sibling;
3130 		if (kid &&
3131 		    (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3132 		    op_null(kid);
3133 	    }
3134 	}
3135 	else
3136 	    o = newLISTOP(OP_SCOPE, 0, o, NULL);
3137     }
3138     return o;
3139 }
3140 
3141 OP *
3142 Perl_op_unscope(pTHX_ OP *o)
3143 {
3144     if (o && o->op_type == OP_LINESEQ) {
3145 	OP *kid = cLISTOPo->op_first;
3146 	for(; kid; kid = kid->op_sibling)
3147 	    if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3148 		op_null(kid);
3149     }
3150     return o;
3151 }
3152 
3153 int
3154 Perl_block_start(pTHX_ int full)
3155 {
3156     dVAR;
3157     const int retval = PL_savestack_ix;
3158 
3159     pad_block_start(full);
3160     SAVEHINTS();
3161     PL_hints &= ~HINT_BLOCK_SCOPE;
3162     SAVECOMPILEWARNINGS();
3163     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3164 
3165     CALL_BLOCK_HOOKS(bhk_start, full);
3166 
3167     return retval;
3168 }
3169 
3170 OP*
3171 Perl_block_end(pTHX_ I32 floor, OP *seq)
3172 {
3173     dVAR;
3174     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3175     OP* retval = scalarseq(seq);
3176     OP *o;
3177 
3178     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3179 
3180     LEAVE_SCOPE(floor);
3181     if (needblockscope)
3182 	PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3183     o = pad_leavemy();
3184 
3185     if (o) {
3186 	/* pad_leavemy has created a sequence of introcv ops for all my
3187 	   subs declared in the block.  We have to replicate that list with
3188 	   clonecv ops, to deal with this situation:
3189 
3190 	       sub {
3191 		   my sub s1;
3192 		   my sub s2;
3193 		   sub s1 { state sub foo { \&s2 } }
3194 	       }->()
3195 
3196 	   Originally, I was going to have introcv clone the CV and turn
3197 	   off the stale flag.  Since &s1 is declared before &s2, the
3198 	   introcv op for &s1 is executed (on sub entry) before the one for
3199 	   &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3200 	   cloned, since it is a state sub) closes over &s2 and expects
3201 	   to see it in its outer CV’s pad.  If the introcv op clones &s1,
3202 	   then &s2 is still marked stale.  Since &s1 is not active, and
3203 	   &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3204 	   ble will not stay shared’ warning.  Because it is the same stub
3205 	   that will be used when the introcv op for &s2 is executed, clos-
3206 	   ing over it is safe.  Hence, we have to turn off the stale flag
3207 	   on all lexical subs in the block before we clone any of them.
3208 	   Hence, having introcv clone the sub cannot work.  So we create a
3209 	   list of ops like this:
3210 
3211 	       lineseq
3212 		  |
3213 		  +-- introcv
3214 		  |
3215 		  +-- introcv
3216 		  |
3217 		  +-- introcv
3218 		  |
3219 		  .
3220 		  .
3221 		  .
3222 		  |
3223 		  +-- clonecv
3224 		  |
3225 		  +-- clonecv
3226 		  |
3227 		  +-- clonecv
3228 		  |
3229 		  .
3230 		  .
3231 		  .
3232 	 */
3233 	OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3234 	OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3235 	for (;; kid = kid->op_sibling) {
3236 	    OP *newkid = newOP(OP_CLONECV, 0);
3237 	    newkid->op_targ = kid->op_targ;
3238 	    o = op_append_elem(OP_LINESEQ, o, newkid);
3239 	    if (kid == last) break;
3240 	}
3241 	retval = op_prepend_elem(OP_LINESEQ, o, retval);
3242     }
3243 
3244     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3245 
3246     return retval;
3247 }
3248 
3249 /*
3250 =head1 Compile-time scope hooks
3251 
3252 =for apidoc Aox||blockhook_register
3253 
3254 Register a set of hooks to be called when the Perl lexical scope changes
3255 at compile time.  See L<perlguts/"Compile-time scope hooks">.
3256 
3257 =cut
3258 */
3259 
3260 void
3261 Perl_blockhook_register(pTHX_ BHK *hk)
3262 {
3263     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3264 
3265     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3266 }
3267 
3268 STATIC OP *
3269 S_newDEFSVOP(pTHX)
3270 {
3271     dVAR;
3272     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3273     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3274 	return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3275     }
3276     else {
3277 	OP * const o = newOP(OP_PADSV, 0);
3278 	o->op_targ = offset;
3279 	return o;
3280     }
3281 }
3282 
3283 void
3284 Perl_newPROG(pTHX_ OP *o)
3285 {
3286     dVAR;
3287 
3288     PERL_ARGS_ASSERT_NEWPROG;
3289 
3290     if (PL_in_eval) {
3291 	PERL_CONTEXT *cx;
3292 	I32 i;
3293 	if (PL_eval_root)
3294 		return;
3295 	PL_eval_root = newUNOP(OP_LEAVEEVAL,
3296 			       ((PL_in_eval & EVAL_KEEPERR)
3297 				? OPf_SPECIAL : 0), o);
3298 
3299 	cx = &cxstack[cxstack_ix];
3300 	assert(CxTYPE(cx) == CXt_EVAL);
3301 
3302 	if ((cx->blk_gimme & G_WANT) == G_VOID)
3303 	    scalarvoid(PL_eval_root);
3304 	else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3305 	    list(PL_eval_root);
3306 	else
3307 	    scalar(PL_eval_root);
3308 
3309 	PL_eval_start = op_linklist(PL_eval_root);
3310 	PL_eval_root->op_private |= OPpREFCOUNTED;
3311 	OpREFCNT_set(PL_eval_root, 1);
3312 	PL_eval_root->op_next = 0;
3313 	i = PL_savestack_ix;
3314 	SAVEFREEOP(o);
3315 	ENTER;
3316 	CALL_PEEP(PL_eval_start);
3317 	finalize_optree(PL_eval_root);
3318         S_prune_chain_head(aTHX_ &PL_eval_start);
3319 	LEAVE;
3320 	PL_savestack_ix = i;
3321     }
3322     else {
3323 	if (o->op_type == OP_STUB) {
3324             /* This block is entered if nothing is compiled for the main
3325                program. This will be the case for an genuinely empty main
3326                program, or one which only has BEGIN blocks etc, so already
3327                run and freed.
3328 
3329                Historically (5.000) the guard above was !o. However, commit
3330                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3331                c71fccf11fde0068, changed perly.y so that newPROG() is now
3332                called with the output of block_end(), which returns a new
3333                OP_STUB for the case of an empty optree. ByteLoader (and
3334                maybe other things) also take this path, because they set up
3335                PL_main_start and PL_main_root directly, without generating an
3336                optree.
3337 
3338                If the parsing the main program aborts (due to parse errors,
3339                or due to BEGIN or similar calling exit), then newPROG()
3340                isn't even called, and hence this code path and its cleanups
3341                are skipped. This shouldn't make a make a difference:
3342                * a non-zero return from perl_parse is a failure, and
3343                  perl_destruct() should be called immediately.
3344                * however, if exit(0) is called during the parse, then
3345                  perl_parse() returns 0, and perl_run() is called. As
3346                  PL_main_start will be NULL, perl_run() will return
3347                  promptly, and the exit code will remain 0.
3348             */
3349 
3350 	    PL_comppad_name = 0;
3351 	    PL_compcv = 0;
3352 	    S_op_destroy(aTHX_ o);
3353 	    return;
3354 	}
3355 	PL_main_root = op_scope(sawparens(scalarvoid(o)));
3356 	PL_curcop = &PL_compiling;
3357 	PL_main_start = LINKLIST(PL_main_root);
3358 	PL_main_root->op_private |= OPpREFCOUNTED;
3359 	OpREFCNT_set(PL_main_root, 1);
3360 	PL_main_root->op_next = 0;
3361 	CALL_PEEP(PL_main_start);
3362 	finalize_optree(PL_main_root);
3363         S_prune_chain_head(aTHX_ &PL_main_start);
3364 	cv_forget_slab(PL_compcv);
3365 	PL_compcv = 0;
3366 
3367 	/* Register with debugger */
3368 	if (PERLDB_INTER) {
3369 	    CV * const cv = get_cvs("DB::postponed", 0);
3370 	    if (cv) {
3371 		dSP;
3372 		PUSHMARK(SP);
3373 		XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3374 		PUTBACK;
3375 		call_sv(MUTABLE_SV(cv), G_DISCARD);
3376 	    }
3377 	}
3378     }
3379 }
3380 
3381 OP *
3382 Perl_localize(pTHX_ OP *o, I32 lex)
3383 {
3384     dVAR;
3385 
3386     PERL_ARGS_ASSERT_LOCALIZE;
3387 
3388     if (o->op_flags & OPf_PARENS)
3389 /* [perl #17376]: this appears to be premature, and results in code such as
3390    C< our(%x); > executing in list mode rather than void mode */
3391 #if 0
3392 	list(o);
3393 #else
3394 	NOOP;
3395 #endif
3396     else {
3397 	if ( PL_parser->bufptr > PL_parser->oldbufptr
3398 	    && PL_parser->bufptr[-1] == ','
3399 	    && ckWARN(WARN_PARENTHESIS))
3400 	{
3401 	    char *s = PL_parser->bufptr;
3402 	    bool sigil = FALSE;
3403 
3404 	    /* some heuristics to detect a potential error */
3405 	    while (*s && (strchr(", \t\n", *s)))
3406 		s++;
3407 
3408 	    while (1) {
3409 		if (*s && strchr("@$%*", *s) && *++s
3410 		       && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3411 		    s++;
3412 		    sigil = TRUE;
3413 		    while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3414 			s++;
3415 		    while (*s && (strchr(", \t\n", *s)))
3416 			s++;
3417 		}
3418 		else
3419 		    break;
3420 	    }
3421 	    if (sigil && (*s == ';' || *s == '=')) {
3422 		Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3423 				"Parentheses missing around \"%s\" list",
3424 				lex
3425 				    ? (PL_parser->in_my == KEY_our
3426 					? "our"
3427 					: PL_parser->in_my == KEY_state
3428 					    ? "state"
3429 					    : "my")
3430 				    : "local");
3431 	    }
3432 	}
3433     }
3434     if (lex)
3435 	o = my(o);
3436     else
3437 	o = op_lvalue(o, OP_NULL);		/* a bit kludgey */
3438     PL_parser->in_my = FALSE;
3439     PL_parser->in_my_stash = NULL;
3440     return o;
3441 }
3442 
3443 OP *
3444 Perl_jmaybe(pTHX_ OP *o)
3445 {
3446     PERL_ARGS_ASSERT_JMAYBE;
3447 
3448     if (o->op_type == OP_LIST) {
3449 	OP * const o2
3450 	    = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3451 	o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3452     }
3453     return o;
3454 }
3455 
3456 PERL_STATIC_INLINE OP *
3457 S_op_std_init(pTHX_ OP *o)
3458 {
3459     I32 type = o->op_type;
3460 
3461     PERL_ARGS_ASSERT_OP_STD_INIT;
3462 
3463     if (PL_opargs[type] & OA_RETSCALAR)
3464 	scalar(o);
3465     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3466 	o->op_targ = pad_alloc(type, SVs_PADTMP);
3467 
3468     return o;
3469 }
3470 
3471 PERL_STATIC_INLINE OP *
3472 S_op_integerize(pTHX_ OP *o)
3473 {
3474     I32 type = o->op_type;
3475 
3476     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3477 
3478     /* integerize op. */
3479     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3480     {
3481 	dVAR;
3482 	o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3483     }
3484 
3485     if (type == OP_NEGATE)
3486 	/* XXX might want a ck_negate() for this */
3487 	cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3488 
3489     return o;
3490 }
3491 
3492 static OP *
3493 S_fold_constants(pTHX_ OP *o)
3494 {
3495     dVAR;
3496     OP * VOL curop;
3497     OP *newop;
3498     VOL I32 type = o->op_type;
3499     SV * VOL sv = NULL;
3500     int ret = 0;
3501     I32 oldscope;
3502     OP *old_next;
3503     SV * const oldwarnhook = PL_warnhook;
3504     SV * const olddiehook  = PL_diehook;
3505     COP not_compiling;
3506     dJMPENV;
3507 
3508     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3509 
3510     if (!(PL_opargs[type] & OA_FOLDCONST))
3511 	goto nope;
3512 
3513     switch (type) {
3514     case OP_UCFIRST:
3515     case OP_LCFIRST:
3516     case OP_UC:
3517     case OP_LC:
3518     case OP_FC:
3519     case OP_SLT:
3520     case OP_SGT:
3521     case OP_SLE:
3522     case OP_SGE:
3523     case OP_SCMP:
3524     case OP_SPRINTF:
3525 	/* XXX what about the numeric ops? */
3526 	if (IN_LOCALE_COMPILETIME)
3527 	    goto nope;
3528 	break;
3529     case OP_PACK:
3530 	if (!cLISTOPo->op_first->op_sibling
3531 	  || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3532 	    goto nope;
3533 	{
3534 	    SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3535 	    if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3536 	    {
3537 		const char *s = SvPVX_const(sv);
3538 		while (s < SvEND(sv)) {
3539 		    if (*s == 'p' || *s == 'P') goto nope;
3540 		    s++;
3541 		}
3542 	    }
3543 	}
3544 	break;
3545     case OP_REPEAT:
3546 	if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3547 	break;
3548     case OP_SREFGEN:
3549 	if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3550 	 || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3551 	    goto nope;
3552     }
3553 
3554     if (PL_parser && PL_parser->error_count)
3555 	goto nope;		/* Don't try to run w/ errors */
3556 
3557     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3558 	const OPCODE type = curop->op_type;
3559 	if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3560 	    type != OP_LIST &&
3561 	    type != OP_SCALAR &&
3562 	    type != OP_NULL &&
3563 	    type != OP_PUSHMARK)
3564 	{
3565 	    goto nope;
3566 	}
3567     }
3568 
3569     curop = LINKLIST(o);
3570     old_next = o->op_next;
3571     o->op_next = 0;
3572     PL_op = curop;
3573 
3574     oldscope = PL_scopestack_ix;
3575     create_eval_scope(G_FAKINGEVAL);
3576 
3577     /* Verify that we don't need to save it:  */
3578     assert(PL_curcop == &PL_compiling);
3579     StructCopy(&PL_compiling, &not_compiling, COP);
3580     PL_curcop = &not_compiling;
3581     /* The above ensures that we run with all the correct hints of the
3582        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3583     assert(IN_PERL_RUNTIME);
3584     PL_warnhook = PERL_WARNHOOK_FATAL;
3585     PL_diehook  = NULL;
3586     JMPENV_PUSH(ret);
3587 
3588     switch (ret) {
3589     case 0:
3590 	CALLRUNOPS(aTHX);
3591 	sv = *(PL_stack_sp--);
3592 	if (o->op_targ && sv == PAD_SV(o->op_targ)) {	/* grab pad temp? */
3593 #ifdef PERL_MAD
3594 	    /* Can't simply swipe the SV from the pad, because that relies on
3595 	       the op being freed "real soon now". Under MAD, this doesn't
3596 	       happen (see the #ifdef below).  */
3597 	    sv = newSVsv(sv);
3598 #else
3599 	    pad_swipe(o->op_targ,  FALSE);
3600 #endif
3601 	}
3602 	else if (SvTEMP(sv)) {			/* grab mortal temp? */
3603 	    SvREFCNT_inc_simple_void(sv);
3604 	    SvTEMP_off(sv);
3605 	}
3606 	else { assert(SvIMMORTAL(sv)); }
3607 	break;
3608     case 3:
3609 	/* Something tried to die.  Abandon constant folding.  */
3610 	/* Pretend the error never happened.  */
3611 	CLEAR_ERRSV();
3612 	o->op_next = old_next;
3613 	break;
3614     default:
3615 	JMPENV_POP;
3616 	/* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3617 	PL_warnhook = oldwarnhook;
3618 	PL_diehook  = olddiehook;
3619 	/* XXX note that this croak may fail as we've already blown away
3620 	 * the stack - eg any nested evals */
3621 	Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3622     }
3623     JMPENV_POP;
3624     PL_warnhook = oldwarnhook;
3625     PL_diehook  = olddiehook;
3626     PL_curcop = &PL_compiling;
3627 
3628     if (PL_scopestack_ix > oldscope)
3629 	delete_eval_scope();
3630 
3631     if (ret)
3632 	goto nope;
3633 
3634 #ifndef PERL_MAD
3635     op_free(o);
3636 #endif
3637     assert(sv);
3638     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3639     else if (!SvIMMORTAL(sv)) {
3640 	SvPADTMP_on(sv);
3641 	SvREADONLY_on(sv);
3642     }
3643     if (type == OP_RV2GV)
3644 	newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3645     else
3646     {
3647 	newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3648 	if (type != OP_STRINGIFY) newop->op_folded = 1;
3649     }
3650     op_getmad(o,newop,'f');
3651     return newop;
3652 
3653  nope:
3654     return o;
3655 }
3656 
3657 static OP *
3658 S_gen_constant_list(pTHX_ OP *o)
3659 {
3660     dVAR;
3661     OP *curop;
3662     const SSize_t oldtmps_floor = PL_tmps_floor;
3663     SV **svp;
3664     AV *av;
3665 
3666     list(o);
3667     if (PL_parser && PL_parser->error_count)
3668 	return o;		/* Don't attempt to run with errors */
3669 
3670     curop = LINKLIST(o);
3671     o->op_next = 0;
3672     CALL_PEEP(curop);
3673     S_prune_chain_head(aTHX_ &curop);
3674     PL_op = curop;
3675     Perl_pp_pushmark(aTHX);
3676     CALLRUNOPS(aTHX);
3677     PL_op = curop;
3678     assert (!(curop->op_flags & OPf_SPECIAL));
3679     assert(curop->op_type == OP_RANGE);
3680     Perl_pp_anonlist(aTHX);
3681     PL_tmps_floor = oldtmps_floor;
3682 
3683     o->op_type = OP_RV2AV;
3684     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3685     o->op_flags &= ~OPf_REF;	/* treat \(1..2) like an ordinary list */
3686     o->op_flags |= OPf_PARENS;	/* and flatten \(1..2,3) */
3687     o->op_opt = 0;		/* needs to be revisited in rpeep() */
3688     curop = ((UNOP*)o)->op_first;
3689     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3690     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3691     if (AvFILLp(av) != -1)
3692 	for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3693 	{
3694 	    SvPADTMP_on(*svp);
3695 	    SvREADONLY_on(*svp);
3696 	}
3697 #ifdef PERL_MAD
3698     op_getmad(curop,o,'O');
3699 #else
3700     op_free(curop);
3701 #endif
3702     LINKLIST(o);
3703     return list(o);
3704 }
3705 
3706 OP *
3707 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3708 {
3709     dVAR;
3710     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3711     if (!o || o->op_type != OP_LIST)
3712 	o = newLISTOP(OP_LIST, 0, o, NULL);
3713     else
3714 	o->op_flags &= ~OPf_WANT;
3715 
3716     if (!(PL_opargs[type] & OA_MARK))
3717 	op_null(cLISTOPo->op_first);
3718     else {
3719 	OP * const kid2 = cLISTOPo->op_first->op_sibling;
3720 	if (kid2 && kid2->op_type == OP_COREARGS) {
3721 	    op_null(cLISTOPo->op_first);
3722 	    kid2->op_private |= OPpCOREARGS_PUSHMARK;
3723 	}
3724     }
3725 
3726     o->op_type = (OPCODE)type;
3727     o->op_ppaddr = PL_ppaddr[type];
3728     o->op_flags |= flags;
3729 
3730     o = CHECKOP(type, o);
3731     if (o->op_type != (unsigned)type)
3732 	return o;
3733 
3734     return fold_constants(op_integerize(op_std_init(o)));
3735 }
3736 
3737 /*
3738 =head1 Optree Manipulation Functions
3739 */
3740 
3741 /* List constructors */
3742 
3743 /*
3744 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3745 
3746 Append an item to the list of ops contained directly within a list-type
3747 op, returning the lengthened list.  I<first> is the list-type op,
3748 and I<last> is the op to append to the list.  I<optype> specifies the
3749 intended opcode for the list.  If I<first> is not already a list of the
3750 right type, it will be upgraded into one.  If either I<first> or I<last>
3751 is null, the other is returned unchanged.
3752 
3753 =cut
3754 */
3755 
3756 OP *
3757 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3758 {
3759     if (!first)
3760 	return last;
3761 
3762     if (!last)
3763 	return first;
3764 
3765     if (first->op_type != (unsigned)type
3766 	|| (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3767     {
3768 	return newLISTOP(type, 0, first, last);
3769     }
3770 
3771     if (first->op_flags & OPf_KIDS)
3772 	((LISTOP*)first)->op_last->op_sibling = last;
3773     else {
3774 	first->op_flags |= OPf_KIDS;
3775 	((LISTOP*)first)->op_first = last;
3776     }
3777     ((LISTOP*)first)->op_last = last;
3778     return first;
3779 }
3780 
3781 /*
3782 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3783 
3784 Concatenate the lists of ops contained directly within two list-type ops,
3785 returning the combined list.  I<first> and I<last> are the list-type ops
3786 to concatenate.  I<optype> specifies the intended opcode for the list.
3787 If either I<first> or I<last> is not already a list of the right type,
3788 it will be upgraded into one.  If either I<first> or I<last> is null,
3789 the other is returned unchanged.
3790 
3791 =cut
3792 */
3793 
3794 OP *
3795 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3796 {
3797     if (!first)
3798 	return last;
3799 
3800     if (!last)
3801 	return first;
3802 
3803     if (first->op_type != (unsigned)type)
3804 	return op_prepend_elem(type, first, last);
3805 
3806     if (last->op_type != (unsigned)type)
3807 	return op_append_elem(type, first, last);
3808 
3809     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3810     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3811     first->op_flags |= (last->op_flags & OPf_KIDS);
3812 
3813 #ifdef PERL_MAD
3814     if (((LISTOP*)last)->op_first && first->op_madprop) {
3815 	MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3816 	if (mp) {
3817 	    while (mp->mad_next)
3818 		mp = mp->mad_next;
3819 	    mp->mad_next = first->op_madprop;
3820 	}
3821 	else {
3822 	    ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3823 	}
3824     }
3825     first->op_madprop = last->op_madprop;
3826     last->op_madprop = 0;
3827 #endif
3828 
3829     S_op_destroy(aTHX_ last);
3830 
3831     return first;
3832 }
3833 
3834 /*
3835 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3836 
3837 Prepend an item to the list of ops contained directly within a list-type
3838 op, returning the lengthened list.  I<first> is the op to prepend to the
3839 list, and I<last> is the list-type op.  I<optype> specifies the intended
3840 opcode for the list.  If I<last> is not already a list of the right type,
3841 it will be upgraded into one.  If either I<first> or I<last> is null,
3842 the other is returned unchanged.
3843 
3844 =cut
3845 */
3846 
3847 OP *
3848 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3849 {
3850     if (!first)
3851 	return last;
3852 
3853     if (!last)
3854 	return first;
3855 
3856     if (last->op_type == (unsigned)type) {
3857 	if (type == OP_LIST) {	/* already a PUSHMARK there */
3858 	    first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3859 	    ((LISTOP*)last)->op_first->op_sibling = first;
3860             if (!(first->op_flags & OPf_PARENS))
3861                 last->op_flags &= ~OPf_PARENS;
3862 	}
3863 	else {
3864 	    if (!(last->op_flags & OPf_KIDS)) {
3865 		((LISTOP*)last)->op_last = first;
3866 		last->op_flags |= OPf_KIDS;
3867 	    }
3868 	    first->op_sibling = ((LISTOP*)last)->op_first;
3869 	    ((LISTOP*)last)->op_first = first;
3870 	}
3871 	last->op_flags |= OPf_KIDS;
3872 	return last;
3873     }
3874 
3875     return newLISTOP(type, 0, first, last);
3876 }
3877 
3878 /* Constructors */
3879 
3880 #ifdef PERL_MAD
3881 
3882 TOKEN *
3883 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3884 {
3885     TOKEN *tk;
3886     Newxz(tk, 1, TOKEN);
3887     tk->tk_type = (OPCODE)optype;
3888     tk->tk_type = 12345;
3889     tk->tk_lval = lval;
3890     tk->tk_mad = madprop;
3891     return tk;
3892 }
3893 
3894 void
3895 Perl_token_free(pTHX_ TOKEN* tk)
3896 {
3897     PERL_ARGS_ASSERT_TOKEN_FREE;
3898 
3899     if (tk->tk_type != 12345)
3900 	return;
3901     mad_free(tk->tk_mad);
3902     Safefree(tk);
3903 }
3904 
3905 void
3906 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3907 {
3908     MADPROP* mp;
3909     MADPROP* tm;
3910 
3911     PERL_ARGS_ASSERT_TOKEN_GETMAD;
3912 
3913     if (tk->tk_type != 12345) {
3914 	Perl_warner(aTHX_ packWARN(WARN_MISC),
3915 	     "Invalid TOKEN object ignored");
3916 	return;
3917     }
3918     tm = tk->tk_mad;
3919     if (!tm)
3920 	return;
3921 
3922     /* faked up qw list? */
3923     if (slot == '(' &&
3924 	tm->mad_type == MAD_SV &&
3925 	SvPVX((SV *)tm->mad_val)[0] == 'q')
3926 	    slot = 'x';
3927 
3928     if (o) {
3929 	mp = o->op_madprop;
3930 	if (mp) {
3931 	    for (;;) {
3932 		/* pretend constant fold didn't happen? */
3933 		if (mp->mad_key == 'f' &&
3934 		    (o->op_type == OP_CONST ||
3935 		     o->op_type == OP_GV) )
3936 		{
3937 		    token_getmad(tk,(OP*)mp->mad_val,slot);
3938 		    return;
3939 		}
3940 		if (!mp->mad_next)
3941 		    break;
3942 		mp = mp->mad_next;
3943 	    }
3944 	    mp->mad_next = tm;
3945 	    mp = mp->mad_next;
3946 	}
3947 	else {
3948 	    o->op_madprop = tm;
3949 	    mp = o->op_madprop;
3950 	}
3951 	if (mp->mad_key == 'X')
3952 	    mp->mad_key = slot;	/* just change the first one */
3953 
3954 	tk->tk_mad = 0;
3955     }
3956     else
3957 	mad_free(tm);
3958     Safefree(tk);
3959 }
3960 
3961 void
3962 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3963 {
3964     MADPROP* mp;
3965     if (!from)
3966 	return;
3967     if (o) {
3968 	mp = o->op_madprop;
3969 	if (mp) {
3970 	    for (;;) {
3971 		/* pretend constant fold didn't happen? */
3972 		if (mp->mad_key == 'f' &&
3973 		    (o->op_type == OP_CONST ||
3974 		     o->op_type == OP_GV) )
3975 		{
3976 		    op_getmad(from,(OP*)mp->mad_val,slot);
3977 		    return;
3978 		}
3979 		if (!mp->mad_next)
3980 		    break;
3981 		mp = mp->mad_next;
3982 	    }
3983 	    mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3984 	}
3985 	else {
3986 	    o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3987 	}
3988     }
3989 }
3990 
3991 void
3992 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3993 {
3994     MADPROP* mp;
3995     if (!from)
3996 	return;
3997     if (o) {
3998 	mp = o->op_madprop;
3999 	if (mp) {
4000 	    for (;;) {
4001 		/* pretend constant fold didn't happen? */
4002 		if (mp->mad_key == 'f' &&
4003 		    (o->op_type == OP_CONST ||
4004 		     o->op_type == OP_GV) )
4005 		{
4006 		    op_getmad(from,(OP*)mp->mad_val,slot);
4007 		    return;
4008 		}
4009 		if (!mp->mad_next)
4010 		    break;
4011 		mp = mp->mad_next;
4012 	    }
4013 	    mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
4014 	}
4015 	else {
4016 	    o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
4017 	}
4018     }
4019     else {
4020 	PerlIO_printf(PerlIO_stderr(),
4021 		      "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
4022 	op_free(from);
4023     }
4024 }
4025 
4026 void
4027 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
4028 {
4029     MADPROP* tm;
4030     if (!mp || !o)
4031 	return;
4032     if (slot)
4033 	mp->mad_key = slot;
4034     tm = o->op_madprop;
4035     o->op_madprop = mp;
4036     for (;;) {
4037 	if (!mp->mad_next)
4038 	    break;
4039 	mp = mp->mad_next;
4040     }
4041     mp->mad_next = tm;
4042 }
4043 
4044 void
4045 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
4046 {
4047     if (!o)
4048 	return;
4049     addmad(tm, &(o->op_madprop), slot);
4050 }
4051 
4052 void
4053 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
4054 {
4055     MADPROP* mp;
4056     if (!tm || !root)
4057 	return;
4058     if (slot)
4059 	tm->mad_key = slot;
4060     mp = *root;
4061     if (!mp) {
4062 	*root = tm;
4063 	return;
4064     }
4065     for (;;) {
4066 	if (!mp->mad_next)
4067 	    break;
4068 	mp = mp->mad_next;
4069     }
4070     mp->mad_next = tm;
4071 }
4072 
4073 MADPROP *
4074 Perl_newMADsv(pTHX_ char key, SV* sv)
4075 {
4076     PERL_ARGS_ASSERT_NEWMADSV;
4077 
4078     return newMADPROP(key, MAD_SV, sv, 0);
4079 }
4080 
4081 MADPROP *
4082 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
4083 {
4084     MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
4085     mp->mad_next = 0;
4086     mp->mad_key = key;
4087     mp->mad_vlen = vlen;
4088     mp->mad_type = type;
4089     mp->mad_val = val;
4090 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
4091     return mp;
4092 }
4093 
4094 void
4095 Perl_mad_free(pTHX_ MADPROP* mp)
4096 {
4097 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
4098     if (!mp)
4099 	return;
4100     if (mp->mad_next)
4101 	mad_free(mp->mad_next);
4102 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
4103 	PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
4104     switch (mp->mad_type) {
4105     case MAD_NULL:
4106 	break;
4107     case MAD_PV:
4108 	Safefree(mp->mad_val);
4109 	break;
4110     case MAD_OP:
4111 	if (mp->mad_vlen)	/* vlen holds "strong/weak" boolean */
4112 	    op_free((OP*)mp->mad_val);
4113 	break;
4114     case MAD_SV:
4115 	sv_free(MUTABLE_SV(mp->mad_val));
4116 	break;
4117     default:
4118 	PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
4119 	break;
4120     }
4121     PerlMemShared_free(mp);
4122 }
4123 
4124 #endif
4125 
4126 /*
4127 =head1 Optree construction
4128 
4129 =for apidoc Am|OP *|newNULLLIST
4130 
4131 Constructs, checks, and returns a new C<stub> op, which represents an
4132 empty list expression.
4133 
4134 =cut
4135 */
4136 
4137 OP *
4138 Perl_newNULLLIST(pTHX)
4139 {
4140     return newOP(OP_STUB, 0);
4141 }
4142 
4143 static OP *
4144 S_force_list(pTHX_ OP *o)
4145 {
4146     if (!o || o->op_type != OP_LIST)
4147 	o = newLISTOP(OP_LIST, 0, o, NULL);
4148     op_null(o);
4149     return o;
4150 }
4151 
4152 /*
4153 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4154 
4155 Constructs, checks, and returns an op of any list type.  I<type> is
4156 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4157 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4158 supply up to two ops to be direct children of the list op; they are
4159 consumed by this function and become part of the constructed op tree.
4160 
4161 =cut
4162 */
4163 
4164 OP *
4165 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4166 {
4167     dVAR;
4168     LISTOP *listop;
4169 
4170     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4171 
4172     NewOp(1101, listop, 1, LISTOP);
4173 
4174     listop->op_type = (OPCODE)type;
4175     listop->op_ppaddr = PL_ppaddr[type];
4176     if (first || last)
4177 	flags |= OPf_KIDS;
4178     listop->op_flags = (U8)flags;
4179 
4180     if (!last && first)
4181 	last = first;
4182     else if (!first && last)
4183 	first = last;
4184     else if (first)
4185 	first->op_sibling = last;
4186     listop->op_first = first;
4187     listop->op_last = last;
4188     if (type == OP_LIST) {
4189 	OP* const pushop = newOP(OP_PUSHMARK, 0);
4190 	pushop->op_sibling = first;
4191 	listop->op_first = pushop;
4192 	listop->op_flags |= OPf_KIDS;
4193 	if (!last)
4194 	    listop->op_last = pushop;
4195     }
4196 
4197     return CHECKOP(type, listop);
4198 }
4199 
4200 /*
4201 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4202 
4203 Constructs, checks, and returns an op of any base type (any type that
4204 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4205 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4206 of C<op_private>.
4207 
4208 =cut
4209 */
4210 
4211 OP *
4212 Perl_newOP(pTHX_ I32 type, I32 flags)
4213 {
4214     dVAR;
4215     OP *o;
4216 
4217     if (type == -OP_ENTEREVAL) {
4218 	type = OP_ENTEREVAL;
4219 	flags |= OPpEVAL_BYTES<<8;
4220     }
4221 
4222     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4223 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4224 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4225 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4226 
4227     NewOp(1101, o, 1, OP);
4228     o->op_type = (OPCODE)type;
4229     o->op_ppaddr = PL_ppaddr[type];
4230     o->op_flags = (U8)flags;
4231 
4232     o->op_next = o;
4233     o->op_private = (U8)(0 | (flags >> 8));
4234     if (PL_opargs[type] & OA_RETSCALAR)
4235 	scalar(o);
4236     if (PL_opargs[type] & OA_TARGET)
4237 	o->op_targ = pad_alloc(type, SVs_PADTMP);
4238     return CHECKOP(type, o);
4239 }
4240 
4241 /*
4242 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4243 
4244 Constructs, checks, and returns an op of any unary type.  I<type> is
4245 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4246 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4247 bits, the eight bits of C<op_private>, except that the bit with value 1
4248 is automatically set.  I<first> supplies an optional op to be the direct
4249 child of the unary op; it is consumed by this function and become part
4250 of the constructed op tree.
4251 
4252 =cut
4253 */
4254 
4255 OP *
4256 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4257 {
4258     dVAR;
4259     UNOP *unop;
4260 
4261     if (type == -OP_ENTEREVAL) {
4262 	type = OP_ENTEREVAL;
4263 	flags |= OPpEVAL_BYTES<<8;
4264     }
4265 
4266     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4267 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4268 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4269 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4270 	|| type == OP_SASSIGN
4271 	|| type == OP_ENTERTRY
4272 	|| type == OP_NULL );
4273 
4274     if (!first)
4275 	first = newOP(OP_STUB, 0);
4276     if (PL_opargs[type] & OA_MARK)
4277 	first = force_list(first);
4278 
4279     NewOp(1101, unop, 1, UNOP);
4280     unop->op_type = (OPCODE)type;
4281     unop->op_ppaddr = PL_ppaddr[type];
4282     unop->op_first = first;
4283     unop->op_flags = (U8)(flags | OPf_KIDS);
4284     unop->op_private = (U8)(1 | (flags >> 8));
4285     unop = (UNOP*) CHECKOP(type, unop);
4286     if (unop->op_next)
4287 	return (OP*)unop;
4288 
4289     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4290 }
4291 
4292 /*
4293 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4294 
4295 Constructs, checks, and returns an op of any binary type.  I<type>
4296 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4297 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4298 the eight bits of C<op_private>, except that the bit with value 1 or
4299 2 is automatically set as required.  I<first> and I<last> supply up to
4300 two ops to be the direct children of the binary op; they are consumed
4301 by this function and become part of the constructed op tree.
4302 
4303 =cut
4304 */
4305 
4306 OP *
4307 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4308 {
4309     dVAR;
4310     BINOP *binop;
4311 
4312     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4313 	|| type == OP_SASSIGN || type == OP_NULL );
4314 
4315     NewOp(1101, binop, 1, BINOP);
4316 
4317     if (!first)
4318 	first = newOP(OP_NULL, 0);
4319 
4320     binop->op_type = (OPCODE)type;
4321     binop->op_ppaddr = PL_ppaddr[type];
4322     binop->op_first = first;
4323     binop->op_flags = (U8)(flags | OPf_KIDS);
4324     if (!last) {
4325 	last = first;
4326 	binop->op_private = (U8)(1 | (flags >> 8));
4327     }
4328     else {
4329 	binop->op_private = (U8)(2 | (flags >> 8));
4330 	first->op_sibling = last;
4331     }
4332 
4333     binop = (BINOP*)CHECKOP(type, binop);
4334     if (binop->op_next || binop->op_type != (OPCODE)type)
4335 	return (OP*)binop;
4336 
4337     binop->op_last = binop->op_first->op_sibling;
4338 
4339     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4340 }
4341 
4342 static int uvcompare(const void *a, const void *b)
4343     __attribute__nonnull__(1)
4344     __attribute__nonnull__(2)
4345     __attribute__pure__;
4346 static int uvcompare(const void *a, const void *b)
4347 {
4348     if (*((const UV *)a) < (*(const UV *)b))
4349 	return -1;
4350     if (*((const UV *)a) > (*(const UV *)b))
4351 	return 1;
4352     if (*((const UV *)a+1) < (*(const UV *)b+1))
4353 	return -1;
4354     if (*((const UV *)a+1) > (*(const UV *)b+1))
4355 	return 1;
4356     return 0;
4357 }
4358 
4359 static OP *
4360 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4361 {
4362     dVAR;
4363     SV * const tstr = ((SVOP*)expr)->op_sv;
4364     SV * const rstr =
4365 #ifdef PERL_MAD
4366 			(repl->op_type == OP_NULL)
4367 			    ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4368 #endif
4369 			      ((SVOP*)repl)->op_sv;
4370     STRLEN tlen;
4371     STRLEN rlen;
4372     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4373     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4374     I32 i;
4375     I32 j;
4376     I32 grows = 0;
4377     short *tbl;
4378 
4379     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4380     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4381     I32 del              = o->op_private & OPpTRANS_DELETE;
4382     SV* swash;
4383 
4384     PERL_ARGS_ASSERT_PMTRANS;
4385 
4386     PL_hints |= HINT_BLOCK_SCOPE;
4387 
4388     if (SvUTF8(tstr))
4389         o->op_private |= OPpTRANS_FROM_UTF;
4390 
4391     if (SvUTF8(rstr))
4392         o->op_private |= OPpTRANS_TO_UTF;
4393 
4394     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4395 	SV* const listsv = newSVpvs("# comment\n");
4396 	SV* transv = NULL;
4397 	const U8* tend = t + tlen;
4398 	const U8* rend = r + rlen;
4399 	STRLEN ulen;
4400 	UV tfirst = 1;
4401 	UV tlast = 0;
4402 	IV tdiff;
4403 	UV rfirst = 1;
4404 	UV rlast = 0;
4405 	IV rdiff;
4406 	IV diff;
4407 	I32 none = 0;
4408 	U32 max = 0;
4409 	I32 bits;
4410 	I32 havefinal = 0;
4411 	U32 final = 0;
4412 	const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4413 	const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4414 	U8* tsave = NULL;
4415 	U8* rsave = NULL;
4416 	const U32 flags = UTF8_ALLOW_DEFAULT;
4417 
4418 	if (!from_utf) {
4419 	    STRLEN len = tlen;
4420 	    t = tsave = bytes_to_utf8(t, &len);
4421 	    tend = t + len;
4422 	}
4423 	if (!to_utf && rlen) {
4424 	    STRLEN len = rlen;
4425 	    r = rsave = bytes_to_utf8(r, &len);
4426 	    rend = r + len;
4427 	}
4428 
4429 /* There is a  snag with this code on EBCDIC: scan_const() in toke.c has
4430  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4431  * odd.  */
4432 
4433 	if (complement) {
4434 	    U8 tmpbuf[UTF8_MAXBYTES+1];
4435 	    UV *cp;
4436 	    UV nextmin = 0;
4437 	    Newx(cp, 2*tlen, UV);
4438 	    i = 0;
4439 	    transv = newSVpvs("");
4440 	    while (t < tend) {
4441 		cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4442 		t += ulen;
4443 		if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4444 		    t++;
4445 		    cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4446 		    t += ulen;
4447 		}
4448 		else {
4449 		 cp[2*i+1] = cp[2*i];
4450 		}
4451 		i++;
4452 	    }
4453 	    qsort(cp, i, 2*sizeof(UV), uvcompare);
4454 	    for (j = 0; j < i; j++) {
4455 		UV  val = cp[2*j];
4456 		diff = val - nextmin;
4457 		if (diff > 0) {
4458 		    t = uvchr_to_utf8(tmpbuf,nextmin);
4459 		    sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4460 		    if (diff > 1) {
4461 			U8  range_mark = ILLEGAL_UTF8_BYTE;
4462 			t = uvchr_to_utf8(tmpbuf, val - 1);
4463 			sv_catpvn(transv, (char *)&range_mark, 1);
4464 			sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4465 		    }
4466 	        }
4467 		val = cp[2*j+1];
4468 		if (val >= nextmin)
4469 		    nextmin = val + 1;
4470 	    }
4471 	    t = uvchr_to_utf8(tmpbuf,nextmin);
4472 	    sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4473 	    {
4474 		U8 range_mark = ILLEGAL_UTF8_BYTE;
4475 		sv_catpvn(transv, (char *)&range_mark, 1);
4476 	    }
4477 	    t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4478 	    sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4479 	    t = (const U8*)SvPVX_const(transv);
4480 	    tlen = SvCUR(transv);
4481 	    tend = t + tlen;
4482 	    Safefree(cp);
4483 	}
4484 	else if (!rlen && !del) {
4485 	    r = t; rlen = tlen; rend = tend;
4486 	}
4487 	if (!squash) {
4488 		if ((!rlen && !del) || t == r ||
4489 		    (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4490 		{
4491 		    o->op_private |= OPpTRANS_IDENTICAL;
4492 		}
4493 	}
4494 
4495 	while (t < tend || tfirst <= tlast) {
4496 	    /* see if we need more "t" chars */
4497 	    if (tfirst > tlast) {
4498 		tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4499 		t += ulen;
4500 		if (t < tend && *t == ILLEGAL_UTF8_BYTE) {	/* illegal utf8 val indicates range */
4501 		    t++;
4502 		    tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4503 		    t += ulen;
4504 		}
4505 		else
4506 		    tlast = tfirst;
4507 	    }
4508 
4509 	    /* now see if we need more "r" chars */
4510 	    if (rfirst > rlast) {
4511 		if (r < rend) {
4512 		    rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4513 		    r += ulen;
4514 		    if (r < rend && *r == ILLEGAL_UTF8_BYTE) {	/* illegal utf8 val indicates range */
4515 			r++;
4516 			rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4517 			r += ulen;
4518 		    }
4519 		    else
4520 			rlast = rfirst;
4521 		}
4522 		else {
4523 		    if (!havefinal++)
4524 			final = rlast;
4525 		    rfirst = rlast = 0xffffffff;
4526 		}
4527 	    }
4528 
4529 	    /* now see which range will peter our first, if either. */
4530 	    tdiff = tlast - tfirst;
4531 	    rdiff = rlast - rfirst;
4532 
4533 	    if (tdiff <= rdiff)
4534 		diff = tdiff;
4535 	    else
4536 		diff = rdiff;
4537 
4538 	    if (rfirst == 0xffffffff) {
4539 		diff = tdiff;	/* oops, pretend rdiff is infinite */
4540 		if (diff > 0)
4541 		    Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4542 				   (long)tfirst, (long)tlast);
4543 		else
4544 		    Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4545 	    }
4546 	    else {
4547 		if (diff > 0)
4548 		    Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4549 				   (long)tfirst, (long)(tfirst + diff),
4550 				   (long)rfirst);
4551 		else
4552 		    Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4553 				   (long)tfirst, (long)rfirst);
4554 
4555 		if (rfirst + diff > max)
4556 		    max = rfirst + diff;
4557 		if (!grows)
4558 		    grows = (tfirst < rfirst &&
4559 			     UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4560 		rfirst += diff + 1;
4561 	    }
4562 	    tfirst += diff + 1;
4563 	}
4564 
4565 	none = ++max;
4566 	if (del)
4567 	    del = ++max;
4568 
4569 	if (max > 0xffff)
4570 	    bits = 32;
4571 	else if (max > 0xff)
4572 	    bits = 16;
4573 	else
4574 	    bits = 8;
4575 
4576 	swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4577 #ifdef USE_ITHREADS
4578 	cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4579 	SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4580 	PAD_SETSV(cPADOPo->op_padix, swash);
4581 	SvPADTMP_on(swash);
4582 	SvREADONLY_on(swash);
4583 #else
4584 	cSVOPo->op_sv = swash;
4585 #endif
4586 	SvREFCNT_dec(listsv);
4587 	SvREFCNT_dec(transv);
4588 
4589 	if (!del && havefinal && rlen)
4590 	    (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4591 			   newSVuv((UV)final), 0);
4592 
4593 	if (grows)
4594 	    o->op_private |= OPpTRANS_GROWS;
4595 
4596 	Safefree(tsave);
4597 	Safefree(rsave);
4598 
4599 #ifdef PERL_MAD
4600 	op_getmad(expr,o,'e');
4601 	op_getmad(repl,o,'r');
4602 #else
4603 	op_free(expr);
4604 	op_free(repl);
4605 #endif
4606 	return o;
4607     }
4608 
4609     tbl = (short*)PerlMemShared_calloc(
4610 	(o->op_private & OPpTRANS_COMPLEMENT) &&
4611 	    !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4612 	sizeof(short));
4613     cPVOPo->op_pv = (char*)tbl;
4614     if (complement) {
4615 	for (i = 0; i < (I32)tlen; i++)
4616 	    tbl[t[i]] = -1;
4617 	for (i = 0, j = 0; i < 256; i++) {
4618 	    if (!tbl[i]) {
4619 		if (j >= (I32)rlen) {
4620 		    if (del)
4621 			tbl[i] = -2;
4622 		    else if (rlen)
4623 			tbl[i] = r[j-1];
4624 		    else
4625 			tbl[i] = (short)i;
4626 		}
4627 		else {
4628 		    if (i < 128 && r[j] >= 128)
4629 			grows = 1;
4630 		    tbl[i] = r[j++];
4631 		}
4632 	    }
4633 	}
4634 	if (!del) {
4635 	    if (!rlen) {
4636 		j = rlen;
4637 		if (!squash)
4638 		    o->op_private |= OPpTRANS_IDENTICAL;
4639 	    }
4640 	    else if (j >= (I32)rlen)
4641 		j = rlen - 1;
4642 	    else {
4643 		tbl =
4644 		    (short *)
4645 		    PerlMemShared_realloc(tbl,
4646 					  (0x101+rlen-j) * sizeof(short));
4647 		cPVOPo->op_pv = (char*)tbl;
4648 	    }
4649 	    tbl[0x100] = (short)(rlen - j);
4650 	    for (i=0; i < (I32)rlen - j; i++)
4651 		tbl[0x101+i] = r[j+i];
4652 	}
4653     }
4654     else {
4655 	if (!rlen && !del) {
4656 	    r = t; rlen = tlen;
4657 	    if (!squash)
4658 		o->op_private |= OPpTRANS_IDENTICAL;
4659 	}
4660 	else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4661 	    o->op_private |= OPpTRANS_IDENTICAL;
4662 	}
4663 	for (i = 0; i < 256; i++)
4664 	    tbl[i] = -1;
4665 	for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4666 	    if (j >= (I32)rlen) {
4667 		if (del) {
4668 		    if (tbl[t[i]] == -1)
4669 			tbl[t[i]] = -2;
4670 		    continue;
4671 		}
4672 		--j;
4673 	    }
4674 	    if (tbl[t[i]] == -1) {
4675 		if (t[i] < 128 && r[j] >= 128)
4676 		    grows = 1;
4677 		tbl[t[i]] = r[j];
4678 	    }
4679 	}
4680     }
4681 
4682     if(del && rlen == tlen) {
4683 	Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
4684     } else if(rlen > tlen && !complement) {
4685 	Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4686     }
4687 
4688     if (grows)
4689 	o->op_private |= OPpTRANS_GROWS;
4690 #ifdef PERL_MAD
4691     op_getmad(expr,o,'e');
4692     op_getmad(repl,o,'r');
4693 #else
4694     op_free(expr);
4695     op_free(repl);
4696 #endif
4697 
4698     return o;
4699 }
4700 
4701 /*
4702 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4703 
4704 Constructs, checks, and returns an op of any pattern matching type.
4705 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4706 and, shifted up eight bits, the eight bits of C<op_private>.
4707 
4708 =cut
4709 */
4710 
4711 OP *
4712 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4713 {
4714     dVAR;
4715     PMOP *pmop;
4716 
4717     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4718 
4719     NewOp(1101, pmop, 1, PMOP);
4720     pmop->op_type = (OPCODE)type;
4721     pmop->op_ppaddr = PL_ppaddr[type];
4722     pmop->op_flags = (U8)flags;
4723     pmop->op_private = (U8)(0 | (flags >> 8));
4724 
4725     if (PL_hints & HINT_RE_TAINT)
4726 	pmop->op_pmflags |= PMf_RETAINT;
4727     if (IN_LOCALE_COMPILETIME) {
4728 	set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4729     }
4730     else if ((! (PL_hints & HINT_BYTES))
4731                 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4732 	     && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4733     {
4734 	set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4735     }
4736     if (PL_hints & HINT_RE_FLAGS) {
4737         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4738          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4739         );
4740         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4741         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4742          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4743         );
4744         if (reflags && SvOK(reflags)) {
4745             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4746         }
4747     }
4748 
4749 
4750 #ifdef USE_ITHREADS
4751     assert(SvPOK(PL_regex_pad[0]));
4752     if (SvCUR(PL_regex_pad[0])) {
4753 	/* Pop off the "packed" IV from the end.  */
4754 	SV *const repointer_list = PL_regex_pad[0];
4755 	const char *p = SvEND(repointer_list) - sizeof(IV);
4756 	const IV offset = *((IV*)p);
4757 
4758 	assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4759 
4760 	SvEND_set(repointer_list, p);
4761 
4762 	pmop->op_pmoffset = offset;
4763 	/* This slot should be free, so assert this:  */
4764 	assert(PL_regex_pad[offset] == &PL_sv_undef);
4765     } else {
4766 	SV * const repointer = &PL_sv_undef;
4767 	av_push(PL_regex_padav, repointer);
4768 	pmop->op_pmoffset = av_tindex(PL_regex_padav);
4769 	PL_regex_pad = AvARRAY(PL_regex_padav);
4770     }
4771 #endif
4772 
4773     return CHECKOP(type, pmop);
4774 }
4775 
4776 /* Given some sort of match op o, and an expression expr containing a
4777  * pattern, either compile expr into a regex and attach it to o (if it's
4778  * constant), or convert expr into a runtime regcomp op sequence (if it's
4779  * not)
4780  *
4781  * isreg indicates that the pattern is part of a regex construct, eg
4782  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4783  * split "pattern", which aren't. In the former case, expr will be a list
4784  * if the pattern contains more than one term (eg /a$b/) or if it contains
4785  * a replacement, ie s/// or tr///.
4786  *
4787  * When the pattern has been compiled within a new anon CV (for
4788  * qr/(?{...})/ ), then floor indicates the savestack level just before
4789  * the new sub was created
4790  */
4791 
4792 OP *
4793 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4794 {
4795     dVAR;
4796     PMOP *pm;
4797     LOGOP *rcop;
4798     I32 repl_has_vars = 0;
4799     OP* repl = NULL;
4800     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4801     bool is_compiletime;
4802     bool has_code;
4803 
4804     PERL_ARGS_ASSERT_PMRUNTIME;
4805 
4806     /* for s/// and tr///, last element in list is the replacement; pop it */
4807 
4808     /* If we have a syntax error causing tokens to be popped and the parser
4809        to see PMFUNC '(' expr ')' with no commas in it; e.g., s/${<>{})//,
4810        then expr will not be of type OP_LIST, there being no repl.  */
4811     if ((is_trans || o->op_type == OP_SUBST) && expr->op_type == OP_LIST) {
4812 	OP* kid;
4813 	repl = cLISTOPx(expr)->op_last;
4814 	kid = cLISTOPx(expr)->op_first;
4815 	while (kid->op_sibling != repl)
4816 	    kid = kid->op_sibling;
4817 	kid->op_sibling = NULL;
4818 	cLISTOPx(expr)->op_last = kid;
4819     }
4820 
4821     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4822 
4823     if (is_trans) {
4824 	OP* const oe = expr;
4825 	assert(expr->op_type == OP_LIST);
4826 	assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4827 	assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4828 	expr = cLISTOPx(oe)->op_last;
4829 	cLISTOPx(oe)->op_first->op_sibling = NULL;
4830 	cLISTOPx(oe)->op_last = NULL;
4831 	op_free(oe);
4832 
4833 	return pmtrans(o, expr, repl);
4834     }
4835 
4836     /* find whether we have any runtime or code elements;
4837      * at the same time, temporarily set the op_next of each DO block;
4838      * then when we LINKLIST, this will cause the DO blocks to be excluded
4839      * from the op_next chain (and from having LINKLIST recursively
4840      * applied to them). We fix up the DOs specially later */
4841 
4842     is_compiletime = 1;
4843     has_code = 0;
4844     if (expr->op_type == OP_LIST) {
4845 	OP *o;
4846 	for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4847 	    if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4848 		has_code = 1;
4849 		assert(!o->op_next && o->op_sibling);
4850 		o->op_next = o->op_sibling;
4851 	    }
4852 	    else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4853 		is_compiletime = 0;
4854 	}
4855     }
4856     else if (expr->op_type != OP_CONST)
4857 	is_compiletime = 0;
4858 
4859     LINKLIST(expr);
4860 
4861     /* fix up DO blocks; treat each one as a separate little sub;
4862      * also, mark any arrays as LIST/REF */
4863 
4864     if (expr->op_type == OP_LIST) {
4865 	OP *o;
4866 	for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4867 
4868             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
4869                 assert( !(o->op_flags  & OPf_WANT));
4870                 /* push the array rather than its contents. The regex
4871                  * engine will retrieve and join the elements later */
4872                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
4873                 continue;
4874             }
4875 
4876 	    if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
4877 		continue;
4878 	    o->op_next = NULL; /* undo temporary hack from above */
4879 	    scalar(o);
4880 	    LINKLIST(o);
4881 	    if (cLISTOPo->op_first->op_type == OP_LEAVE) {
4882 		LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
4883 		/* skip ENTER */
4884 		assert(leaveop->op_first->op_type == OP_ENTER);
4885 		assert(leaveop->op_first->op_sibling);
4886 		o->op_next = leaveop->op_first->op_sibling;
4887 		/* skip leave */
4888 		assert(leaveop->op_flags & OPf_KIDS);
4889 		assert(leaveop->op_last->op_next == (OP*)leaveop);
4890 		leaveop->op_next = NULL; /* stop on last op */
4891 		op_null((OP*)leaveop);
4892 	    }
4893 	    else {
4894 		/* skip SCOPE */
4895 		OP *scope = cLISTOPo->op_first;
4896 		assert(scope->op_type == OP_SCOPE);
4897 		assert(scope->op_flags & OPf_KIDS);
4898 		scope->op_next = NULL; /* stop on last op */
4899 		op_null(scope);
4900 	    }
4901 	    /* have to peep the DOs individually as we've removed it from
4902 	     * the op_next chain */
4903 	    CALL_PEEP(o);
4904             S_prune_chain_head(aTHX_ &(o->op_next));
4905 	    if (is_compiletime)
4906 		/* runtime finalizes as part of finalizing whole tree */
4907 		finalize_optree(o);
4908 	}
4909     }
4910     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
4911         assert( !(expr->op_flags  & OPf_WANT));
4912         /* push the array rather than its contents. The regex
4913          * engine will retrieve and join the elements later */
4914         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
4915     }
4916 
4917     PL_hints |= HINT_BLOCK_SCOPE;
4918     pm = (PMOP*)o;
4919     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
4920 
4921     if (is_compiletime) {
4922 	U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4923 	regexp_engine const *eng = current_re_engine();
4924 
4925         if (o->op_flags & OPf_SPECIAL)
4926             rx_flags |= RXf_SPLIT;
4927 
4928 	if (!has_code || !eng->op_comp) {
4929 	    /* compile-time simple constant pattern */
4930 
4931 	    if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
4932 		/* whoops! we guessed that a qr// had a code block, but we
4933 		 * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
4934 		 * that isn't required now. Note that we have to be pretty
4935 		 * confident that nothing used that CV's pad while the
4936 		 * regex was parsed, except maybe op targets for \Q etc.
4937 		 * If there were any op targets, though, they should have
4938 		 * been stolen by constant folding.
4939 		 */
4940 #ifdef DEBUGGING
4941 		PADOFFSET i = 0;
4942 		assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
4943 		while (++i <= AvFILLp(PL_comppad)) {
4944 		    assert(!PL_curpad[i]);
4945 		}
4946 #endif
4947 		/* But we know that one op is using this CV's slab. */
4948 		cv_forget_slab(PL_compcv);
4949 		LEAVE_SCOPE(floor);
4950 		pm->op_pmflags &= ~PMf_HAS_CV;
4951 	    }
4952 
4953 	    PM_SETRE(pm,
4954 		eng->op_comp
4955 		    ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4956 					rx_flags, pm->op_pmflags)
4957 		    : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4958 					rx_flags, pm->op_pmflags)
4959 	    );
4960 #ifdef PERL_MAD
4961 	    op_getmad(expr,(OP*)pm,'e');
4962 #else
4963 	    op_free(expr);
4964 #endif
4965 	}
4966 	else {
4967 	    /* compile-time pattern that includes literal code blocks */
4968 	    REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
4969 			rx_flags,
4970 			(pm->op_pmflags |
4971 			    ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
4972 		    );
4973 	    PM_SETRE(pm, re);
4974 	    if (pm->op_pmflags & PMf_HAS_CV) {
4975 		CV *cv;
4976 		/* this QR op (and the anon sub we embed it in) is never
4977 		 * actually executed. It's just a placeholder where we can
4978 		 * squirrel away expr in op_code_list without the peephole
4979 		 * optimiser etc processing it for a second time */
4980 		OP *qr = newPMOP(OP_QR, 0);
4981 		((PMOP*)qr)->op_code_list = expr;
4982 
4983 		/* handle the implicit sub{} wrapped round the qr/(?{..})/ */
4984 		SvREFCNT_inc_simple_void(PL_compcv);
4985 		cv = newATTRSUB(floor, 0, NULL, NULL, qr);
4986 		ReANY(re)->qr_anoncv = cv;
4987 
4988 		/* attach the anon CV to the pad so that
4989 		 * pad_fixup_inner_anons() can find it */
4990 		(void)pad_add_anon(cv, o->op_type);
4991 		SvREFCNT_inc_simple_void(cv);
4992 	    }
4993 	    else {
4994 		pm->op_code_list = expr;
4995 	    }
4996 	}
4997     }
4998     else {
4999 	/* runtime pattern: build chain of regcomp etc ops */
5000 	bool reglist;
5001 	PADOFFSET cv_targ = 0;
5002 
5003 	reglist = isreg && expr->op_type == OP_LIST;
5004 	if (reglist)
5005 	    op_null(expr);
5006 
5007 	if (has_code) {
5008 	    pm->op_code_list = expr;
5009 	    /* don't free op_code_list; its ops are embedded elsewhere too */
5010 	    pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5011 	}
5012 
5013         if (o->op_flags & OPf_SPECIAL)
5014             pm->op_pmflags |= PMf_SPLIT;
5015 
5016 	/* the OP_REGCMAYBE is a placeholder in the non-threaded case
5017 	 * to allow its op_next to be pointed past the regcomp and
5018 	 * preceding stacking ops;
5019 	 * OP_REGCRESET is there to reset taint before executing the
5020 	 * stacking ops */
5021 	if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5022 	    expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5023 
5024 	if (pm->op_pmflags & PMf_HAS_CV) {
5025 	    /* we have a runtime qr with literal code. This means
5026 	     * that the qr// has been wrapped in a new CV, which
5027 	     * means that runtime consts, vars etc will have been compiled
5028 	     * against a new pad. So... we need to execute those ops
5029 	     * within the environment of the new CV. So wrap them in a call
5030 	     * to a new anon sub. i.e. for
5031 	     *
5032 	     *     qr/a$b(?{...})/,
5033 	     *
5034 	     * we build an anon sub that looks like
5035 	     *
5036 	     *     sub { "a", $b, '(?{...})' }
5037 	     *
5038 	     * and call it, passing the returned list to regcomp.
5039 	     * Or to put it another way, the list of ops that get executed
5040 	     * are:
5041 	     *
5042 	     *     normal              PMf_HAS_CV
5043 	     *     ------              -------------------
5044 	     *                         pushmark (for regcomp)
5045 	     *                         pushmark (for entersub)
5046 	     *                         pushmark (for refgen)
5047 	     *                         anoncode
5048 	     *                         refgen
5049 	     *                         entersub
5050 	     *     regcreset                  regcreset
5051 	     *     pushmark                   pushmark
5052 	     *     const("a")                 const("a")
5053 	     *     gvsv(b)                    gvsv(b)
5054 	     *     const("(?{...})")          const("(?{...})")
5055 	     *                                leavesub
5056 	     *     regcomp             regcomp
5057 	     */
5058 
5059 	    SvREFCNT_inc_simple_void(PL_compcv);
5060 	    CvLVALUE_on(PL_compcv);
5061 	    /* these lines are just an unrolled newANONATTRSUB */
5062 	    expr = newSVOP(OP_ANONCODE, 0,
5063 		    MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5064 	    cv_targ = expr->op_targ;
5065 	    expr = newUNOP(OP_REFGEN, 0, expr);
5066 
5067 	    expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
5068 	}
5069 
5070 	NewOp(1101, rcop, 1, LOGOP);
5071 	rcop->op_type = OP_REGCOMP;
5072 	rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
5073 	rcop->op_first = scalar(expr);
5074 	rcop->op_flags |= OPf_KIDS
5075 			    | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5076 			    | (reglist ? OPf_STACKED : 0);
5077 	rcop->op_private = 0;
5078 	rcop->op_other = o;
5079 	rcop->op_targ = cv_targ;
5080 
5081 	/* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5082 	if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
5083 
5084 	/* establish postfix order */
5085 	if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5086 	    LINKLIST(expr);
5087 	    rcop->op_next = expr;
5088 	    ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5089 	}
5090 	else {
5091 	    rcop->op_next = LINKLIST(expr);
5092 	    expr->op_next = (OP*)rcop;
5093 	}
5094 
5095 	op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5096     }
5097 
5098     if (repl) {
5099 	OP *curop = repl;
5100 	bool konst;
5101 	/* If we are looking at s//.../e with a single statement, get past
5102 	   the implicit do{}. */
5103 	if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5104 	 && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5105 	 && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
5106 	    OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5107 	    if (kid->op_type == OP_NULL && kid->op_sibling
5108 	     && !kid->op_sibling->op_sibling)
5109 		curop = kid->op_sibling;
5110 	}
5111 	if (curop->op_type == OP_CONST)
5112 	    konst = TRUE;
5113 	else if (( (curop->op_type == OP_RV2SV ||
5114 		    curop->op_type == OP_RV2AV ||
5115 		    curop->op_type == OP_RV2HV ||
5116 		    curop->op_type == OP_RV2GV)
5117 		   && cUNOPx(curop)->op_first
5118 		   && cUNOPx(curop)->op_first->op_type == OP_GV )
5119 		|| curop->op_type == OP_PADSV
5120 		|| curop->op_type == OP_PADAV
5121 		|| curop->op_type == OP_PADHV
5122 		|| curop->op_type == OP_PADANY) {
5123 	    repl_has_vars = 1;
5124 	    konst = TRUE;
5125 	}
5126 	else konst = FALSE;
5127 	if (konst
5128 	    && !(repl_has_vars
5129 		 && (!PM_GETRE(pm)
5130 		     || !RX_PRELEN(PM_GETRE(pm))
5131 		     || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5132 	{
5133 	    pm->op_pmflags |= PMf_CONST;	/* const for long enough */
5134 	    op_prepend_elem(o->op_type, scalar(repl), o);
5135 	}
5136 	else {
5137 	    NewOp(1101, rcop, 1, LOGOP);
5138 	    rcop->op_type = OP_SUBSTCONT;
5139 	    rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
5140 	    rcop->op_first = scalar(repl);
5141 	    rcop->op_flags |= OPf_KIDS;
5142 	    rcop->op_private = 1;
5143 	    rcop->op_other = o;
5144 
5145 	    /* establish postfix order */
5146 	    rcop->op_next = LINKLIST(repl);
5147 	    repl->op_next = (OP*)rcop;
5148 
5149 	    pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5150 	    assert(!(pm->op_pmflags & PMf_ONCE));
5151 	    pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5152 	    rcop->op_next = 0;
5153 	}
5154     }
5155 
5156     return (OP*)pm;
5157 }
5158 
5159 /*
5160 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5161 
5162 Constructs, checks, and returns an op of any type that involves an
5163 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
5164 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
5165 takes ownership of one reference to it.
5166 
5167 =cut
5168 */
5169 
5170 OP *
5171 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5172 {
5173     dVAR;
5174     SVOP *svop;
5175 
5176     PERL_ARGS_ASSERT_NEWSVOP;
5177 
5178     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5179 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5180 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5181 
5182     NewOp(1101, svop, 1, SVOP);
5183     svop->op_type = (OPCODE)type;
5184     svop->op_ppaddr = PL_ppaddr[type];
5185     svop->op_sv = sv;
5186     svop->op_next = (OP*)svop;
5187     svop->op_flags = (U8)flags;
5188     svop->op_private = (U8)(0 | (flags >> 8));
5189     if (PL_opargs[type] & OA_RETSCALAR)
5190 	scalar((OP*)svop);
5191     if (PL_opargs[type] & OA_TARGET)
5192 	svop->op_targ = pad_alloc(type, SVs_PADTMP);
5193     return CHECKOP(type, svop);
5194 }
5195 
5196 #ifdef USE_ITHREADS
5197 
5198 /*
5199 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5200 
5201 Constructs, checks, and returns an op of any type that involves a
5202 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
5203 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5204 is populated with I<sv>; this function takes ownership of one reference
5205 to it.
5206 
5207 This function only exists if Perl has been compiled to use ithreads.
5208 
5209 =cut
5210 */
5211 
5212 OP *
5213 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5214 {
5215     dVAR;
5216     PADOP *padop;
5217 
5218     PERL_ARGS_ASSERT_NEWPADOP;
5219 
5220     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5221 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5222 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5223 
5224     NewOp(1101, padop, 1, PADOP);
5225     padop->op_type = (OPCODE)type;
5226     padop->op_ppaddr = PL_ppaddr[type];
5227     padop->op_padix = pad_alloc(type, SVs_PADTMP);
5228     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5229     PAD_SETSV(padop->op_padix, sv);
5230     assert(sv);
5231     padop->op_next = (OP*)padop;
5232     padop->op_flags = (U8)flags;
5233     if (PL_opargs[type] & OA_RETSCALAR)
5234 	scalar((OP*)padop);
5235     if (PL_opargs[type] & OA_TARGET)
5236 	padop->op_targ = pad_alloc(type, SVs_PADTMP);
5237     return CHECKOP(type, padop);
5238 }
5239 
5240 #endif /* USE_ITHREADS */
5241 
5242 /*
5243 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5244 
5245 Constructs, checks, and returns an op of any type that involves an
5246 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
5247 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
5248 reference; calling this function does not transfer ownership of any
5249 reference to it.
5250 
5251 =cut
5252 */
5253 
5254 OP *
5255 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5256 {
5257     dVAR;
5258 
5259     PERL_ARGS_ASSERT_NEWGVOP;
5260 
5261 #ifdef USE_ITHREADS
5262     GvIN_PAD_on(gv);
5263     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5264 #else
5265     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5266 #endif
5267 }
5268 
5269 /*
5270 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5271 
5272 Constructs, checks, and returns an op of any type that involves an
5273 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
5274 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
5275 must have been allocated using C<PerlMemShared_malloc>; the memory will
5276 be freed when the op is destroyed.
5277 
5278 =cut
5279 */
5280 
5281 OP *
5282 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5283 {
5284     dVAR;
5285     const bool utf8 = cBOOL(flags & SVf_UTF8);
5286     PVOP *pvop;
5287 
5288     flags &= ~SVf_UTF8;
5289 
5290     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5291 	|| type == OP_RUNCV
5292 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5293 
5294     NewOp(1101, pvop, 1, PVOP);
5295     pvop->op_type = (OPCODE)type;
5296     pvop->op_ppaddr = PL_ppaddr[type];
5297     pvop->op_pv = pv;
5298     pvop->op_next = (OP*)pvop;
5299     pvop->op_flags = (U8)flags;
5300     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5301     if (PL_opargs[type] & OA_RETSCALAR)
5302 	scalar((OP*)pvop);
5303     if (PL_opargs[type] & OA_TARGET)
5304 	pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5305     return CHECKOP(type, pvop);
5306 }
5307 
5308 #ifdef PERL_MAD
5309 OP*
5310 #else
5311 void
5312 #endif
5313 Perl_package(pTHX_ OP *o)
5314 {
5315     dVAR;
5316     SV *const sv = cSVOPo->op_sv;
5317 #ifdef PERL_MAD
5318     OP *pegop;
5319 #endif
5320 
5321     PERL_ARGS_ASSERT_PACKAGE;
5322 
5323     SAVEGENERICSV(PL_curstash);
5324     save_item(PL_curstname);
5325 
5326     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5327 
5328     sv_setsv(PL_curstname, sv);
5329 
5330     PL_hints |= HINT_BLOCK_SCOPE;
5331     PL_parser->copline = NOLINE;
5332     PL_parser->expect = XSTATE;
5333 
5334 #ifndef PERL_MAD
5335     op_free(o);
5336 #else
5337     if (!PL_madskills) {
5338 	op_free(o);
5339 	return NULL;
5340     }
5341 
5342     pegop = newOP(OP_NULL,0);
5343     op_getmad(o,pegop,'P');
5344     return pegop;
5345 #endif
5346 }
5347 
5348 void
5349 Perl_package_version( pTHX_ OP *v )
5350 {
5351     dVAR;
5352     U32 savehints = PL_hints;
5353     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5354     PL_hints &= ~HINT_STRICT_VARS;
5355     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5356     PL_hints = savehints;
5357     op_free(v);
5358 }
5359 
5360 #ifdef PERL_MAD
5361 OP*
5362 #else
5363 void
5364 #endif
5365 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5366 {
5367     dVAR;
5368     OP *pack;
5369     OP *imop;
5370     OP *veop;
5371 #ifdef PERL_MAD
5372     OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL;
5373 #endif
5374     SV *use_version = NULL;
5375 
5376     PERL_ARGS_ASSERT_UTILIZE;
5377 
5378     if (idop->op_type != OP_CONST)
5379 	Perl_croak(aTHX_ "Module name must be constant");
5380 
5381     if (PL_madskills)
5382 	op_getmad(idop,pegop,'U');
5383 
5384     veop = NULL;
5385 
5386     if (version) {
5387 	SV * const vesv = ((SVOP*)version)->op_sv;
5388 
5389 	if (PL_madskills)
5390 	    op_getmad(version,pegop,'V');
5391 	if (!arg && !SvNIOKp(vesv)) {
5392 	    arg = version;
5393 	}
5394 	else {
5395 	    OP *pack;
5396 	    SV *meth;
5397 
5398 	    if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5399 		Perl_croak(aTHX_ "Version number must be a constant number");
5400 
5401 	    /* Make copy of idop so we don't free it twice */
5402 	    pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5403 
5404 	    /* Fake up a method call to VERSION */
5405 	    meth = newSVpvs_share("VERSION");
5406 	    veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5407 			    op_append_elem(OP_LIST,
5408 					op_prepend_elem(OP_LIST, pack, list(version)),
5409 					newSVOP(OP_METHOD_NAMED, 0, meth)));
5410 	}
5411     }
5412 
5413     /* Fake up an import/unimport */
5414     if (arg && arg->op_type == OP_STUB) {
5415 	if (PL_madskills)
5416 	    op_getmad(arg,pegop,'S');
5417 	imop = arg;		/* no import on explicit () */
5418     }
5419     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5420 	imop = NULL;		/* use 5.0; */
5421 	if (aver)
5422 	    use_version = ((SVOP*)idop)->op_sv;
5423 	else
5424 	    idop->op_private |= OPpCONST_NOVER;
5425     }
5426     else {
5427 	SV *meth;
5428 
5429 	if (PL_madskills)
5430 	    op_getmad(arg,pegop,'A');
5431 
5432 	/* Make copy of idop so we don't free it twice */
5433 	pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5434 
5435 	/* Fake up a method call to import/unimport */
5436 	meth = aver
5437 	    ? newSVpvs_share("import") : newSVpvs_share("unimport");
5438 	imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5439 		       op_append_elem(OP_LIST,
5440 				   op_prepend_elem(OP_LIST, pack, list(arg)),
5441 				   newSVOP(OP_METHOD_NAMED, 0, meth)));
5442     }
5443 
5444     /* Fake up the BEGIN {}, which does its thing immediately. */
5445     newATTRSUB(floor,
5446 	newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5447 	NULL,
5448 	NULL,
5449 	op_append_elem(OP_LINESEQ,
5450 	    op_append_elem(OP_LINESEQ,
5451 	        newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5452 	        newSTATEOP(0, NULL, veop)),
5453 	    newSTATEOP(0, NULL, imop) ));
5454 
5455     if (use_version) {
5456 	/* Enable the
5457 	 * feature bundle that corresponds to the required version. */
5458 	use_version = sv_2mortal(new_version(use_version));
5459 	S_enable_feature_bundle(aTHX_ use_version);
5460 
5461 	/* If a version >= 5.11.0 is requested, strictures are on by default! */
5462 	if (vcmp(use_version,
5463 		 sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5464 	    if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5465 		PL_hints |= HINT_STRICT_REFS;
5466 	    if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5467 		PL_hints |= HINT_STRICT_SUBS;
5468 	    if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5469 		PL_hints |= HINT_STRICT_VARS;
5470 	}
5471 	/* otherwise they are off */
5472 	else {
5473 	    if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5474 		PL_hints &= ~HINT_STRICT_REFS;
5475 	    if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5476 		PL_hints &= ~HINT_STRICT_SUBS;
5477 	    if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5478 		PL_hints &= ~HINT_STRICT_VARS;
5479 	}
5480     }
5481 
5482     /* The "did you use incorrect case?" warning used to be here.
5483      * The problem is that on case-insensitive filesystems one
5484      * might get false positives for "use" (and "require"):
5485      * "use Strict" or "require CARP" will work.  This causes
5486      * portability problems for the script: in case-strict
5487      * filesystems the script will stop working.
5488      *
5489      * The "incorrect case" warning checked whether "use Foo"
5490      * imported "Foo" to your namespace, but that is wrong, too:
5491      * there is no requirement nor promise in the language that
5492      * a Foo.pm should or would contain anything in package "Foo".
5493      *
5494      * There is very little Configure-wise that can be done, either:
5495      * the case-sensitivity of the build filesystem of Perl does not
5496      * help in guessing the case-sensitivity of the runtime environment.
5497      */
5498 
5499     PL_hints |= HINT_BLOCK_SCOPE;
5500     PL_parser->copline = NOLINE;
5501     PL_parser->expect = XSTATE;
5502     PL_cop_seqmax++; /* Purely for B::*'s benefit */
5503     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5504 	PL_cop_seqmax++;
5505 
5506 #ifdef PERL_MAD
5507     return pegop;
5508 #endif
5509 }
5510 
5511 /*
5512 =head1 Embedding Functions
5513 
5514 =for apidoc load_module
5515 
5516 Loads the module whose name is pointed to by the string part of name.
5517 Note that the actual module name, not its filename, should be given.
5518 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
5519 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5520 (or 0 for no flags).  ver, if specified
5521 and not NULL, provides version semantics
5522 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
5523 arguments can be used to specify arguments to the module's import()
5524 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
5525 terminated with a final NULL pointer.  Note that this list can only
5526 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5527 Otherwise at least a single NULL pointer to designate the default
5528 import list is required.
5529 
5530 The reference count for each specified C<SV*> parameter is decremented.
5531 
5532 =cut */
5533 
5534 void
5535 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5536 {
5537     va_list args;
5538 
5539     PERL_ARGS_ASSERT_LOAD_MODULE;
5540 
5541     va_start(args, ver);
5542     vload_module(flags, name, ver, &args);
5543     va_end(args);
5544 }
5545 
5546 #ifdef PERL_IMPLICIT_CONTEXT
5547 void
5548 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5549 {
5550     dTHX;
5551     va_list args;
5552     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5553     va_start(args, ver);
5554     vload_module(flags, name, ver, &args);
5555     va_end(args);
5556 }
5557 #endif
5558 
5559 void
5560 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5561 {
5562     dVAR;
5563     OP *veop, *imop;
5564     OP * const modname = newSVOP(OP_CONST, 0, name);
5565 
5566     PERL_ARGS_ASSERT_VLOAD_MODULE;
5567 
5568     modname->op_private |= OPpCONST_BARE;
5569     if (ver) {
5570 	veop = newSVOP(OP_CONST, 0, ver);
5571     }
5572     else
5573 	veop = NULL;
5574     if (flags & PERL_LOADMOD_NOIMPORT) {
5575 	imop = sawparens(newNULLLIST());
5576     }
5577     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5578 	imop = va_arg(*args, OP*);
5579     }
5580     else {
5581 	SV *sv;
5582 	imop = NULL;
5583 	sv = va_arg(*args, SV*);
5584 	while (sv) {
5585 	    imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5586 	    sv = va_arg(*args, SV*);
5587 	}
5588     }
5589 
5590     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5591      * that it has a PL_parser to play with while doing that, and also
5592      * that it doesn't mess with any existing parser, by creating a tmp
5593      * new parser with lex_start(). This won't actually be used for much,
5594      * since pp_require() will create another parser for the real work.
5595      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
5596 
5597     ENTER;
5598     SAVEVPTR(PL_curcop);
5599     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5600     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5601 	    veop, modname, imop);
5602     LEAVE;
5603 }
5604 
5605 PERL_STATIC_INLINE OP *
5606 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5607 {
5608     return newUNOP(OP_ENTERSUB, OPf_STACKED,
5609 		   newLISTOP(OP_LIST, 0, arg,
5610 			     newUNOP(OP_RV2CV, 0,
5611 				     newGVOP(OP_GV, 0, gv))));
5612 }
5613 
5614 OP *
5615 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5616 {
5617     dVAR;
5618     OP *doop;
5619     GV *gv;
5620 
5621     PERL_ARGS_ASSERT_DOFILE;
5622 
5623     if (!force_builtin && (gv = gv_override("do", 2))) {
5624 	doop = S_new_entersubop(aTHX_ gv, term);
5625     }
5626     else {
5627 	doop = newUNOP(OP_DOFILE, 0, scalar(term));
5628     }
5629     return doop;
5630 }
5631 
5632 /*
5633 =head1 Optree construction
5634 
5635 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5636 
5637 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
5638 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5639 be set automatically, and, shifted up eight bits, the eight bits of
5640 C<op_private>, except that the bit with value 1 or 2 is automatically
5641 set as required.  I<listval> and I<subscript> supply the parameters of
5642 the slice; they are consumed by this function and become part of the
5643 constructed op tree.
5644 
5645 =cut
5646 */
5647 
5648 OP *
5649 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5650 {
5651     return newBINOP(OP_LSLICE, flags,
5652 	    list(force_list(subscript)),
5653 	    list(force_list(listval)) );
5654 }
5655 
5656 STATIC I32
5657 S_is_list_assignment(pTHX_ const OP *o)
5658 {
5659     unsigned type;
5660     U8 flags;
5661 
5662     if (!o)
5663 	return TRUE;
5664 
5665     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5666 	o = cUNOPo->op_first;
5667 
5668     flags = o->op_flags;
5669     type = o->op_type;
5670     if (type == OP_COND_EXPR) {
5671         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
5672         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
5673 
5674 	if (t && f)
5675 	    return TRUE;
5676 	if (t || f)
5677 	    yyerror("Assignment to both a list and a scalar");
5678 	return FALSE;
5679     }
5680 
5681     if (type == OP_LIST &&
5682 	(flags & OPf_WANT) == OPf_WANT_SCALAR &&
5683 	o->op_private & OPpLVAL_INTRO)
5684 	return FALSE;
5685 
5686     if (type == OP_LIST || flags & OPf_PARENS ||
5687 	type == OP_RV2AV || type == OP_RV2HV ||
5688 	type == OP_ASLICE || type == OP_HSLICE ||
5689         type == OP_KVASLICE || type == OP_KVHSLICE)
5690 	return TRUE;
5691 
5692     if (type == OP_PADAV || type == OP_PADHV)
5693 	return TRUE;
5694 
5695     if (type == OP_RV2SV)
5696 	return FALSE;
5697 
5698     return FALSE;
5699 }
5700 
5701 /*
5702   Helper function for newASSIGNOP to detection commonality between the
5703   lhs and the rhs.  Marks all variables with PL_generation.  If it
5704   returns TRUE the assignment must be able to handle common variables.
5705 */
5706 PERL_STATIC_INLINE bool
5707 S_aassign_common_vars(pTHX_ OP* o)
5708 {
5709     OP *curop;
5710     for (curop = cUNOPo->op_first; curop; curop=curop->op_sibling) {
5711 	if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5712 	    if (curop->op_type == OP_GV) {
5713 		GV *gv = cGVOPx_gv(curop);
5714 		if (gv == PL_defgv
5715 		    || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5716 		    return TRUE;
5717 		GvASSIGN_GENERATION_set(gv, PL_generation);
5718 	    }
5719 	    else if (curop->op_type == OP_PADSV ||
5720 		curop->op_type == OP_PADAV ||
5721 		curop->op_type == OP_PADHV ||
5722 		curop->op_type == OP_PADANY)
5723 		{
5724 		    if (PAD_COMPNAME_GEN(curop->op_targ)
5725 			== (STRLEN)PL_generation)
5726 			return TRUE;
5727 		    PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5728 
5729 		}
5730 	    else if (curop->op_type == OP_RV2CV)
5731 		return TRUE;
5732 	    else if (curop->op_type == OP_RV2SV ||
5733 		curop->op_type == OP_RV2AV ||
5734 		curop->op_type == OP_RV2HV ||
5735 		curop->op_type == OP_RV2GV) {
5736 		if (cUNOPx(curop)->op_first->op_type != OP_GV)	/* funny deref? */
5737 		    return TRUE;
5738 	    }
5739 	    else if (curop->op_type == OP_PUSHRE) {
5740 		GV *const gv =
5741 #ifdef USE_ITHREADS
5742 		    ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5743 			? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5744 			: NULL;
5745 #else
5746 		    ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5747 #endif
5748 		if (gv) {
5749 		    if (gv == PL_defgv
5750 			|| (int)GvASSIGN_GENERATION(gv) == PL_generation)
5751 			return TRUE;
5752 		    GvASSIGN_GENERATION_set(gv, PL_generation);
5753 		}
5754 	    }
5755 	    else
5756 		return TRUE;
5757 	}
5758 
5759 	if (curop->op_flags & OPf_KIDS) {
5760 	    if (aassign_common_vars(curop))
5761 		return TRUE;
5762 	}
5763     }
5764     return FALSE;
5765 }
5766 
5767 /*
5768 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
5769 
5770 Constructs, checks, and returns an assignment op.  I<left> and I<right>
5771 supply the parameters of the assignment; they are consumed by this
5772 function and become part of the constructed op tree.
5773 
5774 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
5775 a suitable conditional optree is constructed.  If I<optype> is the opcode
5776 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
5777 performs the binary operation and assigns the result to the left argument.
5778 Either way, if I<optype> is non-zero then I<flags> has no effect.
5779 
5780 If I<optype> is zero, then a plain scalar or list assignment is
5781 constructed.  Which type of assignment it is is automatically determined.
5782 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
5783 will be set automatically, and, shifted up eight bits, the eight bits
5784 of C<op_private>, except that the bit with value 1 or 2 is automatically
5785 set as required.
5786 
5787 =cut
5788 */
5789 
5790 OP *
5791 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
5792 {
5793     dVAR;
5794     OP *o;
5795 
5796     if (optype) {
5797 	if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
5798 	    return newLOGOP(optype, 0,
5799 		op_lvalue(scalar(left), optype),
5800 		newUNOP(OP_SASSIGN, 0, scalar(right)));
5801 	}
5802 	else {
5803 	    return newBINOP(optype, OPf_STACKED,
5804 		op_lvalue(scalar(left), optype), scalar(right));
5805 	}
5806     }
5807 
5808     if (is_list_assignment(left)) {
5809 	static const char no_list_state[] = "Initialization of state variables"
5810 	    " in list context currently forbidden";
5811 	OP *curop;
5812 	bool maybe_common_vars = TRUE;
5813 
5814 	if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
5815 	    left->op_private &= ~ OPpSLICEWARNING;
5816 
5817 	PL_modcount = 0;
5818 	left = op_lvalue(left, OP_AASSIGN);
5819 	curop = list(force_list(left));
5820 	o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
5821 	o->op_private = (U8)(0 | (flags >> 8));
5822 
5823 	if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
5824 	{
5825 	    OP* lop = ((LISTOP*)left)->op_first;
5826 	    maybe_common_vars = FALSE;
5827 	    while (lop) {
5828 		if (lop->op_type == OP_PADSV ||
5829 		    lop->op_type == OP_PADAV ||
5830 		    lop->op_type == OP_PADHV ||
5831 		    lop->op_type == OP_PADANY) {
5832 		    if (!(lop->op_private & OPpLVAL_INTRO))
5833 			maybe_common_vars = TRUE;
5834 
5835 		    if (lop->op_private & OPpPAD_STATE) {
5836 			if (left->op_private & OPpLVAL_INTRO) {
5837 			    /* Each variable in state($a, $b, $c) = ... */
5838 			}
5839 			else {
5840 			    /* Each state variable in
5841 			       (state $a, my $b, our $c, $d, undef) = ... */
5842 			}
5843 			yyerror(no_list_state);
5844 		    } else {
5845 			/* Each my variable in
5846 			   (state $a, my $b, our $c, $d, undef) = ... */
5847 		    }
5848 		} else if (lop->op_type == OP_UNDEF ||
5849                            OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
5850 		    /* undef may be interesting in
5851 		       (state $a, undef, state $c) */
5852 		} else {
5853 		    /* Other ops in the list. */
5854 		    maybe_common_vars = TRUE;
5855 		}
5856 		lop = lop->op_sibling;
5857 	    }
5858 	}
5859 	else if ((left->op_private & OPpLVAL_INTRO)
5860 		&& (   left->op_type == OP_PADSV
5861 		    || left->op_type == OP_PADAV
5862 		    || left->op_type == OP_PADHV
5863 		    || left->op_type == OP_PADANY))
5864 	{
5865 	    if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
5866 	    if (left->op_private & OPpPAD_STATE) {
5867 		/* All single variable list context state assignments, hence
5868 		   state ($a) = ...
5869 		   (state $a) = ...
5870 		   state @a = ...
5871 		   state (@a) = ...
5872 		   (state @a) = ...
5873 		   state %a = ...
5874 		   state (%a) = ...
5875 		   (state %a) = ...
5876 		*/
5877 		yyerror(no_list_state);
5878 	    }
5879 	}
5880 
5881 	/* PL_generation sorcery:
5882 	 * an assignment like ($a,$b) = ($c,$d) is easier than
5883 	 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
5884 	 * To detect whether there are common vars, the global var
5885 	 * PL_generation is incremented for each assign op we compile.
5886 	 * Then, while compiling the assign op, we run through all the
5887 	 * variables on both sides of the assignment, setting a spare slot
5888 	 * in each of them to PL_generation. If any of them already have
5889 	 * that value, we know we've got commonality.  We could use a
5890 	 * single bit marker, but then we'd have to make 2 passes, first
5891 	 * to clear the flag, then to test and set it.  To find somewhere
5892 	 * to store these values, evil chicanery is done with SvUVX().
5893 	 */
5894 
5895 	if (maybe_common_vars) {
5896 	    PL_generation++;
5897 	    if (aassign_common_vars(o))
5898 		o->op_private |= OPpASSIGN_COMMON;
5899 	    LINKLIST(o);
5900 	}
5901 
5902 	if (right && right->op_type == OP_SPLIT && !PL_madskills) {
5903 	    OP* tmpop = ((LISTOP*)right)->op_first;
5904 	    if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
5905 		PMOP * const pm = (PMOP*)tmpop;
5906 		if (left->op_type == OP_RV2AV &&
5907 		    !(left->op_private & OPpLVAL_INTRO) &&
5908 		    !(o->op_private & OPpASSIGN_COMMON) )
5909 		{
5910 		    tmpop = ((UNOP*)left)->op_first;
5911 		    if (tmpop->op_type == OP_GV
5912 #ifdef USE_ITHREADS
5913 			&& !pm->op_pmreplrootu.op_pmtargetoff
5914 #else
5915 			&& !pm->op_pmreplrootu.op_pmtargetgv
5916 #endif
5917 			) {
5918 #ifdef USE_ITHREADS
5919 			pm->op_pmreplrootu.op_pmtargetoff
5920 			    = cPADOPx(tmpop)->op_padix;
5921 			cPADOPx(tmpop)->op_padix = 0;	/* steal it */
5922 #else
5923 			pm->op_pmreplrootu.op_pmtargetgv
5924 			    = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
5925 			cSVOPx(tmpop)->op_sv = NULL;	/* steal it */
5926 #endif
5927 			tmpop = cUNOPo->op_first;	/* to list (nulled) */
5928 			tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
5929 			tmpop->op_sibling = NULL;	/* don't free split */
5930 			right->op_next = tmpop->op_next;  /* fix starting loc */
5931 			op_free(o);			/* blow off assign */
5932 			right->op_flags &= ~OPf_WANT;
5933 				/* "I don't know and I don't care." */
5934 			return right;
5935 		    }
5936 		}
5937 		else {
5938                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
5939 		      ((LISTOP*)right)->op_last->op_type == OP_CONST)
5940 		    {
5941 			SV ** const svp =
5942 			    &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
5943 			SV * const sv = *svp;
5944 			if (SvIOK(sv) && SvIVX(sv) == 0)
5945 			{
5946 			  if (right->op_private & OPpSPLIT_IMPLIM) {
5947 			    /* our own SV, created in ck_split */
5948 			    SvREADONLY_off(sv);
5949 			    sv_setiv(sv, PL_modcount+1);
5950 			  }
5951 			  else {
5952 			    /* SV may belong to someone else */
5953 			    SvREFCNT_dec(sv);
5954 			    *svp = newSViv(PL_modcount+1);
5955 			  }
5956 			}
5957 		    }
5958 		}
5959 	    }
5960 	}
5961 	return o;
5962     }
5963     if (!right)
5964 	right = newOP(OP_UNDEF, 0);
5965     if (right->op_type == OP_READLINE) {
5966 	right->op_flags |= OPf_STACKED;
5967 	return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
5968 		scalar(right));
5969     }
5970     else {
5971 	o = newBINOP(OP_SASSIGN, flags,
5972 	    scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
5973     }
5974     return o;
5975 }
5976 
5977 /*
5978 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
5979 
5980 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
5981 but will be a C<dbstate> op if debugging is enabled for currently-compiled
5982 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
5983 If I<label> is non-null, it supplies the name of a label to attach to
5984 the state op; this function takes ownership of the memory pointed at by
5985 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
5986 for the state op.
5987 
5988 If I<o> is null, the state op is returned.  Otherwise the state op is
5989 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
5990 is consumed by this function and becomes part of the returned op tree.
5991 
5992 =cut
5993 */
5994 
5995 OP *
5996 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
5997 {
5998     dVAR;
5999     const U32 seq = intro_my();
6000     const U32 utf8 = flags & SVf_UTF8;
6001     COP *cop;
6002 
6003     flags &= ~SVf_UTF8;
6004 
6005     NewOp(1101, cop, 1, COP);
6006     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6007 	cop->op_type = OP_DBSTATE;
6008 	cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
6009     }
6010     else {
6011 	cop->op_type = OP_NEXTSTATE;
6012 	cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
6013     }
6014     cop->op_flags = (U8)flags;
6015     CopHINTS_set(cop, PL_hints);
6016 #ifdef NATIVE_HINTS
6017     cop->op_private |= NATIVE_HINTS;
6018 #endif
6019 #ifdef VMS
6020     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6021 #endif
6022     cop->op_next = (OP*)cop;
6023 
6024     cop->cop_seq = seq;
6025     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6026     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6027     if (label) {
6028 	Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6029 
6030 	PL_hints |= HINT_BLOCK_SCOPE;
6031 	/* It seems that we need to defer freeing this pointer, as other parts
6032 	   of the grammar end up wanting to copy it after this op has been
6033 	   created. */
6034 	SAVEFREEPV(label);
6035     }
6036 
6037     if (PL_parser->preambling != NOLINE) {
6038         CopLINE_set(cop, PL_parser->preambling);
6039         PL_parser->copline = NOLINE;
6040     }
6041     else if (PL_parser->copline == NOLINE)
6042         CopLINE_set(cop, CopLINE(PL_curcop));
6043     else {
6044 	CopLINE_set(cop, PL_parser->copline);
6045 	PL_parser->copline = NOLINE;
6046     }
6047 #ifdef USE_ITHREADS
6048     CopFILE_set(cop, CopFILE(PL_curcop));	/* XXX share in a pvtable? */
6049 #else
6050     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6051 #endif
6052     CopSTASH_set(cop, PL_curstash);
6053 
6054     if (cop->op_type == OP_DBSTATE) {
6055 	/* this line can have a breakpoint - store the cop in IV */
6056 	AV *av = CopFILEAVx(PL_curcop);
6057 	if (av) {
6058 	    SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6059 	    if (svp && *svp != &PL_sv_undef ) {
6060 		(void)SvIOK_on(*svp);
6061 		SvIV_set(*svp, PTR2IV(cop));
6062 	    }
6063 	}
6064     }
6065 
6066     if (flags & OPf_SPECIAL)
6067 	op_null((OP*)cop);
6068     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6069 }
6070 
6071 /*
6072 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6073 
6074 Constructs, checks, and returns a logical (flow control) op.  I<type>
6075 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
6076 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6077 the eight bits of C<op_private>, except that the bit with value 1 is
6078 automatically set.  I<first> supplies the expression controlling the
6079 flow, and I<other> supplies the side (alternate) chain of ops; they are
6080 consumed by this function and become part of the constructed op tree.
6081 
6082 =cut
6083 */
6084 
6085 OP *
6086 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6087 {
6088     dVAR;
6089 
6090     PERL_ARGS_ASSERT_NEWLOGOP;
6091 
6092     return new_logop(type, flags, &first, &other);
6093 }
6094 
6095 STATIC OP *
6096 S_search_const(pTHX_ OP *o)
6097 {
6098     PERL_ARGS_ASSERT_SEARCH_CONST;
6099 
6100     switch (o->op_type) {
6101 	case OP_CONST:
6102 	    return o;
6103 	case OP_NULL:
6104 	    if (o->op_flags & OPf_KIDS)
6105 		return search_const(cUNOPo->op_first);
6106 	    break;
6107 	case OP_LEAVE:
6108 	case OP_SCOPE:
6109 	case OP_LINESEQ:
6110 	{
6111 	    OP *kid;
6112 	    if (!(o->op_flags & OPf_KIDS))
6113 		return NULL;
6114 	    kid = cLISTOPo->op_first;
6115 	    do {
6116 		switch (kid->op_type) {
6117 		    case OP_ENTER:
6118 		    case OP_NULL:
6119 		    case OP_NEXTSTATE:
6120 			kid = kid->op_sibling;
6121 			break;
6122 		    default:
6123 			if (kid != cLISTOPo->op_last)
6124 			    return NULL;
6125 			goto last;
6126 		}
6127 	    } while (kid);
6128 	    if (!kid)
6129 		kid = cLISTOPo->op_last;
6130 last:
6131 	    return search_const(kid);
6132 	}
6133     }
6134 
6135     return NULL;
6136 }
6137 
6138 STATIC OP *
6139 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6140 {
6141     dVAR;
6142     LOGOP *logop;
6143     OP *o;
6144     OP *first;
6145     OP *other;
6146     OP *cstop = NULL;
6147     int prepend_not = 0;
6148 
6149     PERL_ARGS_ASSERT_NEW_LOGOP;
6150 
6151     first = *firstp;
6152     other = *otherp;
6153 
6154     /* [perl #59802]: Warn about things like "return $a or $b", which
6155        is parsed as "(return $a) or $b" rather than "return ($a or
6156        $b)".  NB: This also applies to xor, which is why we do it
6157        here.
6158      */
6159     switch (first->op_type) {
6160     case OP_NEXT:
6161     case OP_LAST:
6162     case OP_REDO:
6163 	/* XXX: Perhaps we should emit a stronger warning for these.
6164 	   Even with the high-precedence operator they don't seem to do
6165 	   anything sensible.
6166 
6167 	   But until we do, fall through here.
6168          */
6169     case OP_RETURN:
6170     case OP_EXIT:
6171     case OP_DIE:
6172     case OP_GOTO:
6173 	/* XXX: Currently we allow people to "shoot themselves in the
6174 	   foot" by explicitly writing "(return $a) or $b".
6175 
6176 	   Warn unless we are looking at the result from folding or if
6177 	   the programmer explicitly grouped the operators like this.
6178 	   The former can occur with e.g.
6179 
6180 		use constant FEATURE => ( $] >= ... );
6181 		sub { not FEATURE and return or do_stuff(); }
6182 	 */
6183 	if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6184 	    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6185 	                   "Possible precedence issue with control flow operator");
6186 	/* XXX: Should we optimze this to "return $a;" (i.e. remove
6187 	   the "or $b" part)?
6188 	*/
6189 	break;
6190     }
6191 
6192     if (type == OP_XOR)		/* Not short circuit, but here by precedence. */
6193 	return newBINOP(type, flags, scalar(first), scalar(other));
6194 
6195     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6196 
6197     scalarboolean(first);
6198     /* optimize AND and OR ops that have NOTs as children */
6199     if (first->op_type == OP_NOT
6200 	&& (first->op_flags & OPf_KIDS)
6201 	&& ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6202 	    || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6203 	&& !PL_madskills) {
6204 	if (type == OP_AND || type == OP_OR) {
6205 	    if (type == OP_AND)
6206 		type = OP_OR;
6207 	    else
6208 		type = OP_AND;
6209 	    op_null(first);
6210 	    if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6211 		op_null(other);
6212 		prepend_not = 1; /* prepend a NOT op later */
6213 	    }
6214 	}
6215     }
6216     /* search for a constant op that could let us fold the test */
6217     if ((cstop = search_const(first))) {
6218 	if (cstop->op_private & OPpCONST_STRICT)
6219 	    no_bareword_allowed(cstop);
6220 	else if ((cstop->op_private & OPpCONST_BARE))
6221 		Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6222 	if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6223 	    (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6224 	    (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6225 	    *firstp = NULL;
6226 	    if (other->op_type == OP_CONST)
6227 		other->op_private |= OPpCONST_SHORTCIRCUIT;
6228 	    if (PL_madskills) {
6229 		OP *newop = newUNOP(OP_NULL, 0, other);
6230 		op_getmad(first, newop, '1');
6231 		newop->op_targ = type;	/* set "was" field */
6232 		return newop;
6233 	    }
6234 	    op_free(first);
6235 	    if (other->op_type == OP_LEAVE)
6236 		other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6237 	    else if (other->op_type == OP_MATCH
6238 	          || other->op_type == OP_SUBST
6239 	          || other->op_type == OP_TRANSR
6240 	          || other->op_type == OP_TRANS)
6241 		/* Mark the op as being unbindable with =~ */
6242 		other->op_flags |= OPf_SPECIAL;
6243 
6244 	    other->op_folded = 1;
6245 	    return other;
6246 	}
6247 	else {
6248 	    /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6249 	    const OP *o2 = other;
6250 	    if ( ! (o2->op_type == OP_LIST
6251 		    && (( o2 = cUNOPx(o2)->op_first))
6252 		    && o2->op_type == OP_PUSHMARK
6253 		    && (( o2 = o2->op_sibling)) )
6254 	    )
6255 		o2 = other;
6256 	    if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6257 			|| o2->op_type == OP_PADHV)
6258 		&& o2->op_private & OPpLVAL_INTRO
6259 		&& !(o2->op_private & OPpPAD_STATE))
6260 	    {
6261 		Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6262 				 "Deprecated use of my() in false conditional");
6263 	    }
6264 
6265 	    *otherp = NULL;
6266 	    if (cstop->op_type == OP_CONST)
6267 		cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6268 	    if (PL_madskills) {
6269 		first = newUNOP(OP_NULL, 0, first);
6270 		op_getmad(other, first, '2');
6271 		first->op_targ = type;	/* set "was" field */
6272 	    }
6273 	    else
6274 		op_free(other);
6275 	    return first;
6276 	}
6277     }
6278     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6279 	&& ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6280     {
6281 	const OP * const k1 = ((UNOP*)first)->op_first;
6282 	const OP * const k2 = k1->op_sibling;
6283 	OPCODE warnop = 0;
6284 	switch (first->op_type)
6285 	{
6286 	case OP_NULL:
6287 	    if (k2 && k2->op_type == OP_READLINE
6288 		  && (k2->op_flags & OPf_STACKED)
6289 		  && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6290 	    {
6291 		warnop = k2->op_type;
6292 	    }
6293 	    break;
6294 
6295 	case OP_SASSIGN:
6296 	    if (k1->op_type == OP_READDIR
6297 		  || k1->op_type == OP_GLOB
6298 		  || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6299                  || k1->op_type == OP_EACH
6300                  || k1->op_type == OP_AEACH)
6301 	    {
6302 		warnop = ((k1->op_type == OP_NULL)
6303 			  ? (OPCODE)k1->op_targ : k1->op_type);
6304 	    }
6305 	    break;
6306 	}
6307 	if (warnop) {
6308 	    const line_t oldline = CopLINE(PL_curcop);
6309             /* This ensures that warnings are reported at the first line
6310                of the construction, not the last.  */
6311 	    CopLINE_set(PL_curcop, PL_parser->copline);
6312 	    Perl_warner(aTHX_ packWARN(WARN_MISC),
6313 		 "Value of %s%s can be \"0\"; test with defined()",
6314 		 PL_op_desc[warnop],
6315 		 ((warnop == OP_READLINE || warnop == OP_GLOB)
6316 		  ? " construct" : "() operator"));
6317 	    CopLINE_set(PL_curcop, oldline);
6318 	}
6319     }
6320 
6321     if (!other)
6322 	return first;
6323 
6324     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6325 	other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6326 
6327     NewOp(1101, logop, 1, LOGOP);
6328 
6329     logop->op_type = (OPCODE)type;
6330     logop->op_ppaddr = PL_ppaddr[type];
6331     logop->op_first = first;
6332     logop->op_flags = (U8)(flags | OPf_KIDS);
6333     logop->op_other = LINKLIST(other);
6334     logop->op_private = (U8)(1 | (flags >> 8));
6335 
6336     /* establish postfix order */
6337     logop->op_next = LINKLIST(first);
6338     first->op_next = (OP*)logop;
6339     first->op_sibling = other;
6340 
6341     CHECKOP(type,logop);
6342 
6343     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6344     other->op_next = o;
6345 
6346     return o;
6347 }
6348 
6349 /*
6350 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6351 
6352 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6353 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6354 will be set automatically, and, shifted up eight bits, the eight bits of
6355 C<op_private>, except that the bit with value 1 is automatically set.
6356 I<first> supplies the expression selecting between the two branches,
6357 and I<trueop> and I<falseop> supply the branches; they are consumed by
6358 this function and become part of the constructed op tree.
6359 
6360 =cut
6361 */
6362 
6363 OP *
6364 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6365 {
6366     dVAR;
6367     LOGOP *logop;
6368     OP *start;
6369     OP *o;
6370     OP *cstop;
6371 
6372     PERL_ARGS_ASSERT_NEWCONDOP;
6373 
6374     if (!falseop)
6375 	return newLOGOP(OP_AND, 0, first, trueop);
6376     if (!trueop)
6377 	return newLOGOP(OP_OR, 0, first, falseop);
6378 
6379     scalarboolean(first);
6380     if ((cstop = search_const(first))) {
6381 	/* Left or right arm of the conditional?  */
6382 	const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6383 	OP *live = left ? trueop : falseop;
6384 	OP *const dead = left ? falseop : trueop;
6385         if (cstop->op_private & OPpCONST_BARE &&
6386 	    cstop->op_private & OPpCONST_STRICT) {
6387 	    no_bareword_allowed(cstop);
6388 	}
6389 	if (PL_madskills) {
6390 	    /* This is all dead code when PERL_MAD is not defined.  */
6391 	    live = newUNOP(OP_NULL, 0, live);
6392 	    op_getmad(first, live, 'C');
6393 	    op_getmad(dead, live, left ? 'e' : 't');
6394 	} else {
6395 	    op_free(first);
6396 	    op_free(dead);
6397 	}
6398 	if (live->op_type == OP_LEAVE)
6399 	    live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6400 	else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6401 	      || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6402 	    /* Mark the op as being unbindable with =~ */
6403 	    live->op_flags |= OPf_SPECIAL;
6404 	live->op_folded = 1;
6405 	return live;
6406     }
6407     NewOp(1101, logop, 1, LOGOP);
6408     logop->op_type = OP_COND_EXPR;
6409     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6410     logop->op_first = first;
6411     logop->op_flags = (U8)(flags | OPf_KIDS);
6412     logop->op_private = (U8)(1 | (flags >> 8));
6413     logop->op_other = LINKLIST(trueop);
6414     logop->op_next = LINKLIST(falseop);
6415 
6416     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6417 	    logop);
6418 
6419     /* establish postfix order */
6420     start = LINKLIST(first);
6421     first->op_next = (OP*)logop;
6422 
6423     first->op_sibling = trueop;
6424     trueop->op_sibling = falseop;
6425     o = newUNOP(OP_NULL, 0, (OP*)logop);
6426 
6427     trueop->op_next = falseop->op_next = o;
6428 
6429     o->op_next = start;
6430     return o;
6431 }
6432 
6433 /*
6434 =for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
6435 
6436 Constructs and returns a C<range> op, with subordinate C<flip> and
6437 C<flop> ops.  I<flags> gives the eight bits of C<op_flags> for the
6438 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
6439 for both the C<flip> and C<range> ops, except that the bit with value
6440 1 is automatically set.  I<left> and I<right> supply the expressions
6441 controlling the endpoints of the range; they are consumed by this function
6442 and become part of the constructed op tree.
6443 
6444 =cut
6445 */
6446 
6447 OP *
6448 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
6449 {
6450     dVAR;
6451     LOGOP *range;
6452     OP *flip;
6453     OP *flop;
6454     OP *leftstart;
6455     OP *o;
6456 
6457     PERL_ARGS_ASSERT_NEWRANGE;
6458 
6459     NewOp(1101, range, 1, LOGOP);
6460 
6461     range->op_type = OP_RANGE;
6462     range->op_ppaddr = PL_ppaddr[OP_RANGE];
6463     range->op_first = left;
6464     range->op_flags = OPf_KIDS;
6465     leftstart = LINKLIST(left);
6466     range->op_other = LINKLIST(right);
6467     range->op_private = (U8)(1 | (flags >> 8));
6468 
6469     left->op_sibling = right;
6470 
6471     range->op_next = (OP*)range;
6472     flip = newUNOP(OP_FLIP, flags, (OP*)range);
6473     flop = newUNOP(OP_FLOP, 0, flip);
6474     o = newUNOP(OP_NULL, 0, flop);
6475     LINKLIST(flop);
6476     range->op_next = leftstart;
6477 
6478     left->op_next = flip;
6479     right->op_next = flop;
6480 
6481     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6482     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
6483     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
6484     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
6485 
6486     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6487     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
6488 
6489     /* check barewords before they might be optimized aways */
6490     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
6491 	no_bareword_allowed(left);
6492     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
6493 	no_bareword_allowed(right);
6494 
6495     flip->op_next = o;
6496     if (!flip->op_private || !flop->op_private)
6497 	LINKLIST(o);		/* blow off optimizer unless constant */
6498 
6499     return o;
6500 }
6501 
6502 /*
6503 =for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
6504 
6505 Constructs, checks, and returns an op tree expressing a loop.  This is
6506 only a loop in the control flow through the op tree; it does not have
6507 the heavyweight loop structure that allows exiting the loop by C<last>
6508 and suchlike.  I<flags> gives the eight bits of C<op_flags> for the
6509 top-level op, except that some bits will be set automatically as required.
6510 I<expr> supplies the expression controlling loop iteration, and I<block>
6511 supplies the body of the loop; they are consumed by this function and
6512 become part of the constructed op tree.  I<debuggable> is currently
6513 unused and should always be 1.
6514 
6515 =cut
6516 */
6517 
6518 OP *
6519 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
6520 {
6521     dVAR;
6522     OP* listop;
6523     OP* o;
6524     const bool once = block && block->op_flags & OPf_SPECIAL &&
6525 		      block->op_type == OP_NULL;
6526 
6527     PERL_UNUSED_ARG(debuggable);
6528 
6529     if (expr) {
6530 	if (once && (
6531 	      (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
6532 	   || (  expr->op_type == OP_NOT
6533 	      && cUNOPx(expr)->op_first->op_type == OP_CONST
6534 	      && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
6535 	      )
6536 	   ))
6537 	    /* Return the block now, so that S_new_logop does not try to
6538 	       fold it away. */
6539 	    return block;	/* do {} while 0 does once */
6540 	if (expr->op_type == OP_READLINE
6541 	    || expr->op_type == OP_READDIR
6542 	    || expr->op_type == OP_GLOB
6543 	    || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6544 	    || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6545 	    expr = newUNOP(OP_DEFINED, 0,
6546 		newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6547 	} else if (expr->op_flags & OPf_KIDS) {
6548 	    const OP * const k1 = ((UNOP*)expr)->op_first;
6549 	    const OP * const k2 = k1 ? k1->op_sibling : NULL;
6550 	    switch (expr->op_type) {
6551 	      case OP_NULL:
6552 		if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6553 		      && (k2->op_flags & OPf_STACKED)
6554 		      && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6555 		    expr = newUNOP(OP_DEFINED, 0, expr);
6556 		break;
6557 
6558 	      case OP_SASSIGN:
6559 		if (k1 && (k1->op_type == OP_READDIR
6560 		      || k1->op_type == OP_GLOB
6561 		      || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6562                      || k1->op_type == OP_EACH
6563                      || k1->op_type == OP_AEACH))
6564 		    expr = newUNOP(OP_DEFINED, 0, expr);
6565 		break;
6566 	    }
6567 	}
6568     }
6569 
6570     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
6571      * op, in listop. This is wrong. [perl #27024] */
6572     if (!block)
6573 	block = newOP(OP_NULL, 0);
6574     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
6575     o = new_logop(OP_AND, 0, &expr, &listop);
6576 
6577     if (once) {
6578 	ASSUME(listop);
6579     }
6580 
6581     if (listop)
6582 	((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
6583 
6584     if (once && o != listop)
6585     {
6586 	assert(cUNOPo->op_first->op_type == OP_AND
6587 	    || cUNOPo->op_first->op_type == OP_OR);
6588 	o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
6589     }
6590 
6591     if (o == listop)
6592 	o = newUNOP(OP_NULL, 0, o);	/* or do {} while 1 loses outer block */
6593 
6594     o->op_flags |= flags;
6595     o = op_scope(o);
6596     o->op_flags |= OPf_SPECIAL;	/* suppress POPBLOCK curpm restoration*/
6597     return o;
6598 }
6599 
6600 /*
6601 =for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|OP *expr|OP *block|OP *cont|I32 has_my
6602 
6603 Constructs, checks, and returns an op tree expressing a C<while> loop.
6604 This is a heavyweight loop, with structure that allows exiting the loop
6605 by C<last> and suchlike.
6606 
6607 I<loop> is an optional preconstructed C<enterloop> op to use in the
6608 loop; if it is null then a suitable op will be constructed automatically.
6609 I<expr> supplies the loop's controlling expression.  I<block> supplies the
6610 main body of the loop, and I<cont> optionally supplies a C<continue> block
6611 that operates as a second half of the body.  All of these optree inputs
6612 are consumed by this function and become part of the constructed op tree.
6613 
6614 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6615 op and, shifted up eight bits, the eight bits of C<op_private> for
6616 the C<leaveloop> op, except that (in both cases) some bits will be set
6617 automatically.  I<debuggable> is currently unused and should always be 1.
6618 I<has_my> can be supplied as true to force the
6619 loop body to be enclosed in its own scope.
6620 
6621 =cut
6622 */
6623 
6624 OP *
6625 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
6626 	OP *expr, OP *block, OP *cont, I32 has_my)
6627 {
6628     dVAR;
6629     OP *redo;
6630     OP *next = NULL;
6631     OP *listop;
6632     OP *o;
6633     U8 loopflags = 0;
6634 
6635     PERL_UNUSED_ARG(debuggable);
6636 
6637     if (expr) {
6638 	if (expr->op_type == OP_READLINE
6639          || expr->op_type == OP_READDIR
6640          || expr->op_type == OP_GLOB
6641 	 || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
6642 		     || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
6643 	    expr = newUNOP(OP_DEFINED, 0,
6644 		newASSIGNOP(0, newDEFSVOP(), 0, expr) );
6645 	} else if (expr->op_flags & OPf_KIDS) {
6646 	    const OP * const k1 = ((UNOP*)expr)->op_first;
6647 	    const OP * const k2 = (k1) ? k1->op_sibling : NULL;
6648 	    switch (expr->op_type) {
6649 	      case OP_NULL:
6650 		if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
6651 		      && (k2->op_flags & OPf_STACKED)
6652 		      && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6653 		    expr = newUNOP(OP_DEFINED, 0, expr);
6654 		break;
6655 
6656 	      case OP_SASSIGN:
6657 		if (k1 && (k1->op_type == OP_READDIR
6658 		      || k1->op_type == OP_GLOB
6659 		      || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6660                      || k1->op_type == OP_EACH
6661                      || k1->op_type == OP_AEACH))
6662 		    expr = newUNOP(OP_DEFINED, 0, expr);
6663 		break;
6664 	    }
6665 	}
6666     }
6667 
6668     if (!block)
6669 	block = newOP(OP_NULL, 0);
6670     else if (cont || has_my) {
6671 	block = op_scope(block);
6672     }
6673 
6674     if (cont) {
6675 	next = LINKLIST(cont);
6676     }
6677     if (expr) {
6678 	OP * const unstack = newOP(OP_UNSTACK, 0);
6679 	if (!next)
6680 	    next = unstack;
6681 	cont = op_append_elem(OP_LINESEQ, cont, unstack);
6682     }
6683 
6684     assert(block);
6685     listop = op_append_list(OP_LINESEQ, block, cont);
6686     assert(listop);
6687     redo = LINKLIST(listop);
6688 
6689     if (expr) {
6690 	scalar(listop);
6691 	o = new_logop(OP_AND, 0, &expr, &listop);
6692 	if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
6693 	    op_free((OP*)loop);
6694 	    return expr;		/* listop already freed by new_logop */
6695 	}
6696 	if (listop)
6697 	    ((LISTOP*)listop)->op_last->op_next =
6698 		(o == listop ? redo : LINKLIST(o));
6699     }
6700     else
6701 	o = listop;
6702 
6703     if (!loop) {
6704 	NewOp(1101,loop,1,LOOP);
6705 	loop->op_type = OP_ENTERLOOP;
6706 	loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
6707 	loop->op_private = 0;
6708 	loop->op_next = (OP*)loop;
6709     }
6710 
6711     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
6712 
6713     loop->op_redoop = redo;
6714     loop->op_lastop = o;
6715     o->op_private |= loopflags;
6716 
6717     if (next)
6718 	loop->op_nextop = next;
6719     else
6720 	loop->op_nextop = o;
6721 
6722     o->op_flags |= flags;
6723     o->op_private |= (flags >> 8);
6724     return o;
6725 }
6726 
6727 /*
6728 =for apidoc Am|OP *|newFOROP|I32 flags|OP *sv|OP *expr|OP *block|OP *cont
6729 
6730 Constructs, checks, and returns an op tree expressing a C<foreach>
6731 loop (iteration through a list of values).  This is a heavyweight loop,
6732 with structure that allows exiting the loop by C<last> and suchlike.
6733 
6734 I<sv> optionally supplies the variable that will be aliased to each
6735 item in turn; if null, it defaults to C<$_> (either lexical or global).
6736 I<expr> supplies the list of values to iterate over.  I<block> supplies
6737 the main body of the loop, and I<cont> optionally supplies a C<continue>
6738 block that operates as a second half of the body.  All of these optree
6739 inputs are consumed by this function and become part of the constructed
6740 op tree.
6741 
6742 I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
6743 op and, shifted up eight bits, the eight bits of C<op_private> for
6744 the C<leaveloop> op, except that (in both cases) some bits will be set
6745 automatically.
6746 
6747 =cut
6748 */
6749 
6750 OP *
6751 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
6752 {
6753     dVAR;
6754     LOOP *loop;
6755     OP *wop;
6756     PADOFFSET padoff = 0;
6757     I32 iterflags = 0;
6758     I32 iterpflags = 0;
6759     OP *madsv = NULL;
6760 
6761     PERL_ARGS_ASSERT_NEWFOROP;
6762 
6763     if (sv) {
6764 	if (sv->op_type == OP_RV2SV) {	/* symbol table variable */
6765 	    iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
6766 	    sv->op_type = OP_RV2GV;
6767 	    sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
6768 
6769 	    /* The op_type check is needed to prevent a possible segfault
6770 	     * if the loop variable is undeclared and 'strict vars' is in
6771 	     * effect. This is illegal but is nonetheless parsed, so we
6772 	     * may reach this point with an OP_CONST where we're expecting
6773 	     * an OP_GV.
6774 	     */
6775 	    if (cUNOPx(sv)->op_first->op_type == OP_GV
6776 	     && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
6777 		iterpflags |= OPpITER_DEF;
6778 	}
6779 	else if (sv->op_type == OP_PADSV) { /* private variable */
6780 	    iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
6781 	    padoff = sv->op_targ;
6782 	    if (PL_madskills)
6783 		madsv = sv;
6784 	    else {
6785 		sv->op_targ = 0;
6786 		op_free(sv);
6787 	    }
6788 	    sv = NULL;
6789 	}
6790 	else
6791 	    Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
6792 	if (padoff) {
6793 	    SV *const namesv = PAD_COMPNAME_SV(padoff);
6794 	    STRLEN len;
6795 	    const char *const name = SvPV_const(namesv, len);
6796 
6797 	    if (len == 2 && name[0] == '$' && name[1] == '_')
6798 		iterpflags |= OPpITER_DEF;
6799 	}
6800     }
6801     else {
6802         const PADOFFSET offset = pad_findmy_pvs("$_", 0);
6803 	if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6804 	    sv = newGVOP(OP_GV, 0, PL_defgv);
6805 	}
6806 	else {
6807 	    padoff = offset;
6808 	}
6809 	iterpflags |= OPpITER_DEF;
6810     }
6811     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
6812 	expr = op_lvalue(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
6813 	iterflags |= OPf_STACKED;
6814     }
6815     else if (expr->op_type == OP_NULL &&
6816              (expr->op_flags & OPf_KIDS) &&
6817              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
6818     {
6819 	/* Basically turn for($x..$y) into the same as for($x,$y), but we
6820 	 * set the STACKED flag to indicate that these values are to be
6821 	 * treated as min/max values by 'pp_enteriter'.
6822 	 */
6823 	const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
6824 	LOGOP* const range = (LOGOP*) flip->op_first;
6825 	OP* const left  = range->op_first;
6826 	OP* const right = left->op_sibling;
6827 	LISTOP* listop;
6828 
6829 	range->op_flags &= ~OPf_KIDS;
6830 	range->op_first = NULL;
6831 
6832 	listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
6833 	listop->op_first->op_next = range->op_next;
6834 	left->op_next = range->op_other;
6835 	right->op_next = (OP*)listop;
6836 	listop->op_next = listop->op_first;
6837 
6838 #ifdef PERL_MAD
6839 	op_getmad(expr,(OP*)listop,'O');
6840 #else
6841 	op_free(expr);
6842 #endif
6843 	expr = (OP*)(listop);
6844         op_null(expr);
6845 	iterflags |= OPf_STACKED;
6846     }
6847     else {
6848         expr = op_lvalue(force_list(expr), OP_GREPSTART);
6849     }
6850 
6851     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
6852 			       op_append_elem(OP_LIST, expr, scalar(sv))));
6853     assert(!loop->op_next);
6854     /* for my  $x () sets OPpLVAL_INTRO;
6855      * for our $x () sets OPpOUR_INTRO */
6856     loop->op_private = (U8)iterpflags;
6857     if (loop->op_slabbed
6858      && DIFF(loop, OpSLOT(loop)->opslot_next)
6859 	 < SIZE_TO_PSIZE(sizeof(LOOP)))
6860     {
6861 	LOOP *tmp;
6862 	NewOp(1234,tmp,1,LOOP);
6863 	Copy(loop,tmp,1,LISTOP);
6864 	S_op_destroy(aTHX_ (OP*)loop);
6865 	loop = tmp;
6866     }
6867     else if (!loop->op_slabbed)
6868 	loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
6869     loop->op_targ = padoff;
6870     wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
6871     if (madsv)
6872 	op_getmad(madsv, (OP*)loop, 'v');
6873     return wop;
6874 }
6875 
6876 /*
6877 =for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
6878 
6879 Constructs, checks, and returns a loop-exiting op (such as C<goto>
6880 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
6881 determining the target of the op; it is consumed by this function and
6882 becomes part of the constructed op tree.
6883 
6884 =cut
6885 */
6886 
6887 OP*
6888 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
6889 {
6890     dVAR;
6891     OP *o = NULL;
6892 
6893     PERL_ARGS_ASSERT_NEWLOOPEX;
6894 
6895     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
6896 
6897     if (type != OP_GOTO) {
6898 	/* "last()" means "last" */
6899 	if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
6900 	    o = newOP(type, OPf_SPECIAL);
6901 	}
6902     }
6903     else {
6904 	/* Check whether it's going to be a goto &function */
6905 	if (label->op_type == OP_ENTERSUB
6906 		&& !(label->op_flags & OPf_STACKED))
6907 	    label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
6908     }
6909 
6910     /* Check for a constant argument */
6911     if (label->op_type == OP_CONST) {
6912 	    SV * const sv = ((SVOP *)label)->op_sv;
6913 	    STRLEN l;
6914 	    const char *s = SvPV_const(sv,l);
6915 	    if (l == strlen(s)) {
6916 		o = newPVOP(type,
6917 			    SvUTF8(((SVOP*)label)->op_sv),
6918 			    savesharedpv(
6919 				SvPV_nolen_const(((SVOP*)label)->op_sv)));
6920 	    }
6921     }
6922 
6923     /* If we have already created an op, we do not need the label. */
6924     if (o)
6925 #ifdef PERL_MAD
6926 		op_getmad(label,o,'L');
6927 #else
6928 		op_free(label);
6929 #endif
6930     else o = newUNOP(type, OPf_STACKED, label);
6931 
6932     PL_hints |= HINT_BLOCK_SCOPE;
6933     return o;
6934 }
6935 
6936 /* if the condition is a literal array or hash
6937    (or @{ ... } etc), make a reference to it.
6938  */
6939 STATIC OP *
6940 S_ref_array_or_hash(pTHX_ OP *cond)
6941 {
6942     if (cond
6943     && (cond->op_type == OP_RV2AV
6944     ||  cond->op_type == OP_PADAV
6945     ||  cond->op_type == OP_RV2HV
6946     ||  cond->op_type == OP_PADHV))
6947 
6948 	return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
6949 
6950     else if(cond
6951     && (cond->op_type == OP_ASLICE
6952     ||  cond->op_type == OP_KVASLICE
6953     ||  cond->op_type == OP_HSLICE
6954     ||  cond->op_type == OP_KVHSLICE)) {
6955 
6956 	/* anonlist now needs a list from this op, was previously used in
6957 	 * scalar context */
6958 	cond->op_flags |= ~(OPf_WANT_SCALAR | OPf_REF);
6959 	cond->op_flags |= OPf_WANT_LIST;
6960 
6961 	return newANONLIST(op_lvalue(cond, OP_ANONLIST));
6962     }
6963 
6964     else
6965 	return cond;
6966 }
6967 
6968 /* These construct the optree fragments representing given()
6969    and when() blocks.
6970 
6971    entergiven and enterwhen are LOGOPs; the op_other pointer
6972    points up to the associated leave op. We need this so we
6973    can put it in the context and make break/continue work.
6974    (Also, of course, pp_enterwhen will jump straight to
6975    op_other if the match fails.)
6976  */
6977 
6978 STATIC OP *
6979 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
6980 		   I32 enter_opcode, I32 leave_opcode,
6981 		   PADOFFSET entertarg)
6982 {
6983     dVAR;
6984     LOGOP *enterop;
6985     OP *o;
6986 
6987     PERL_ARGS_ASSERT_NEWGIVWHENOP;
6988 
6989     NewOp(1101, enterop, 1, LOGOP);
6990     enterop->op_type = (Optype)enter_opcode;
6991     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
6992     enterop->op_flags =  (U8) OPf_KIDS;
6993     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
6994     enterop->op_private = 0;
6995 
6996     o = newUNOP(leave_opcode, 0, (OP *) enterop);
6997 
6998     if (cond) {
6999 	enterop->op_first = scalar(cond);
7000 	cond->op_sibling = block;
7001 
7002 	o->op_next = LINKLIST(cond);
7003 	cond->op_next = (OP *) enterop;
7004     }
7005     else {
7006 	/* This is a default {} block */
7007 	enterop->op_first = block;
7008 	enterop->op_flags |= OPf_SPECIAL;
7009 	o      ->op_flags |= OPf_SPECIAL;
7010 
7011 	o->op_next = (OP *) enterop;
7012     }
7013 
7014     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
7015     				       entergiven and enterwhen both
7016     				       use ck_null() */
7017 
7018     enterop->op_next = LINKLIST(block);
7019     block->op_next = enterop->op_other = o;
7020 
7021     return o;
7022 }
7023 
7024 /* Does this look like a boolean operation? For these purposes
7025    a boolean operation is:
7026      - a subroutine call [*]
7027      - a logical connective
7028      - a comparison operator
7029      - a filetest operator, with the exception of -s -M -A -C
7030      - defined(), exists() or eof()
7031      - /$re/ or $foo =~ /$re/
7032 
7033    [*] possibly surprising
7034  */
7035 STATIC bool
7036 S_looks_like_bool(pTHX_ const OP *o)
7037 {
7038     dVAR;
7039 
7040     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
7041 
7042     switch(o->op_type) {
7043 	case OP_OR:
7044 	case OP_DOR:
7045 	    return looks_like_bool(cLOGOPo->op_first);
7046 
7047 	case OP_AND:
7048 	    return (
7049 	    	looks_like_bool(cLOGOPo->op_first)
7050 	     && looks_like_bool(cLOGOPo->op_first->op_sibling));
7051 
7052 	case OP_NULL:
7053 	case OP_SCALAR:
7054 	    return (
7055 		o->op_flags & OPf_KIDS
7056 	    && looks_like_bool(cUNOPo->op_first));
7057 
7058 	case OP_ENTERSUB:
7059 
7060 	case OP_NOT:	case OP_XOR:
7061 
7062 	case OP_EQ:	case OP_NE:	case OP_LT:
7063 	case OP_GT:	case OP_LE:	case OP_GE:
7064 
7065 	case OP_I_EQ:	case OP_I_NE:	case OP_I_LT:
7066 	case OP_I_GT:	case OP_I_LE:	case OP_I_GE:
7067 
7068 	case OP_SEQ:	case OP_SNE:	case OP_SLT:
7069 	case OP_SGT:	case OP_SLE:	case OP_SGE:
7070 
7071 	case OP_SMARTMATCH:
7072 
7073 	case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
7074 	case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
7075 	case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
7076 	case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
7077 	case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
7078 	case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
7079 	case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
7080 	case OP_FTTEXT:   case OP_FTBINARY:
7081 
7082 	case OP_DEFINED: case OP_EXISTS:
7083 	case OP_MATCH:	 case OP_EOF:
7084 
7085 	case OP_FLOP:
7086 
7087 	    return TRUE;
7088 
7089 	case OP_CONST:
7090 	    /* Detect comparisons that have been optimized away */
7091 	    if (cSVOPo->op_sv == &PL_sv_yes
7092 	    ||  cSVOPo->op_sv == &PL_sv_no)
7093 
7094 		return TRUE;
7095 	    else
7096 		return FALSE;
7097 
7098 	/* FALL THROUGH */
7099 	default:
7100 	    return FALSE;
7101     }
7102 }
7103 
7104 /*
7105 =for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
7106 
7107 Constructs, checks, and returns an op tree expressing a C<given> block.
7108 I<cond> supplies the expression that will be locally assigned to a lexical
7109 variable, and I<block> supplies the body of the C<given> construct; they
7110 are consumed by this function and become part of the constructed op tree.
7111 I<defsv_off> is the pad offset of the scalar lexical variable that will
7112 be affected.  If it is 0, the global $_ will be used.
7113 
7114 =cut
7115 */
7116 
7117 OP *
7118 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
7119 {
7120     dVAR;
7121     PERL_ARGS_ASSERT_NEWGIVENOP;
7122     return newGIVWHENOP(
7123     	ref_array_or_hash(cond),
7124     	block,
7125 	OP_ENTERGIVEN, OP_LEAVEGIVEN,
7126 	defsv_off);
7127 }
7128 
7129 /*
7130 =for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
7131 
7132 Constructs, checks, and returns an op tree expressing a C<when> block.
7133 I<cond> supplies the test expression, and I<block> supplies the block
7134 that will be executed if the test evaluates to true; they are consumed
7135 by this function and become part of the constructed op tree.  I<cond>
7136 will be interpreted DWIMically, often as a comparison against C<$_>,
7137 and may be null to generate a C<default> block.
7138 
7139 =cut
7140 */
7141 
7142 OP *
7143 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
7144 {
7145     const bool cond_llb = (!cond || looks_like_bool(cond));
7146     OP *cond_op;
7147 
7148     PERL_ARGS_ASSERT_NEWWHENOP;
7149 
7150     if (cond_llb)
7151 	cond_op = cond;
7152     else {
7153 	cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
7154 		newDEFSVOP(),
7155 		scalar(ref_array_or_hash(cond)));
7156     }
7157 
7158     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
7159 }
7160 
7161 void
7162 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
7163 		    const STRLEN len, const U32 flags)
7164 {
7165     SV *name = NULL, *msg;
7166     const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
7167     STRLEN clen = CvPROTOLEN(cv), plen = len;
7168 
7169     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
7170 
7171     if (p == NULL && cvp == NULL)
7172 	return;
7173 
7174     if (!ckWARN_d(WARN_PROTOTYPE))
7175 	return;
7176 
7177     if (p && cvp) {
7178 	p = S_strip_spaces(aTHX_ p, &plen);
7179 	cvp = S_strip_spaces(aTHX_ cvp, &clen);
7180 	if ((flags & SVf_UTF8) == SvUTF8(cv)) {
7181 	    if (plen == clen && memEQ(cvp, p, plen))
7182 		return;
7183 	} else {
7184 	    if (flags & SVf_UTF8) {
7185 		if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
7186 		    return;
7187             }
7188 	    else {
7189 		if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
7190 		    return;
7191 	    }
7192 	}
7193     }
7194 
7195     msg = sv_newmortal();
7196 
7197     if (gv)
7198     {
7199 	if (isGV(gv))
7200 	    gv_efullname3(name = sv_newmortal(), gv, NULL);
7201 	else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
7202 	    name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
7203 	else name = (SV *)gv;
7204     }
7205     sv_setpvs(msg, "Prototype mismatch:");
7206     if (name)
7207 	Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
7208     if (cvp)
7209 	Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
7210 	    UTF8fARG(SvUTF8(cv),clen,cvp)
7211 	);
7212     else
7213 	sv_catpvs(msg, ": none");
7214     sv_catpvs(msg, " vs ");
7215     if (p)
7216 	Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
7217     else
7218 	sv_catpvs(msg, "none");
7219     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
7220 }
7221 
7222 static void const_sv_xsub(pTHX_ CV* cv);
7223 static void const_av_xsub(pTHX_ CV* cv);
7224 
7225 /*
7226 
7227 =head1 Optree Manipulation Functions
7228 
7229 =for apidoc cv_const_sv
7230 
7231 If C<cv> is a constant sub eligible for inlining, returns the constant
7232 value returned by the sub.  Otherwise, returns NULL.
7233 
7234 Constant subs can be created with C<newCONSTSUB> or as described in
7235 L<perlsub/"Constant Functions">.
7236 
7237 =cut
7238 */
7239 SV *
7240 Perl_cv_const_sv(pTHX_ const CV *const cv)
7241 {
7242     SV *sv;
7243     PERL_UNUSED_CONTEXT;
7244     if (!cv)
7245 	return NULL;
7246     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
7247 	return NULL;
7248     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7249     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
7250     return sv;
7251 }
7252 
7253 SV *
7254 Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
7255 {
7256     PERL_UNUSED_CONTEXT;
7257     if (!cv)
7258 	return NULL;
7259     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
7260     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
7261 }
7262 
7263 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
7264  * Can be called in 3 ways:
7265  *
7266  * !cv
7267  * 	look for a single OP_CONST with attached value: return the value
7268  *
7269  * cv && CvCLONE(cv) && !CvCONST(cv)
7270  *
7271  * 	examine the clone prototype, and if contains only a single
7272  * 	OP_CONST referencing a pad const, or a single PADSV referencing
7273  * 	an outer lexical, return a non-zero value to indicate the CV is
7274  * 	a candidate for "constizing" at clone time
7275  *
7276  * cv && CvCONST(cv)
7277  *
7278  *	We have just cloned an anon prototype that was marked as a const
7279  *	candidate. Try to grab the current value, and in the case of
7280  *	PADSV, ignore it if it has multiple references. In this case we
7281  *	return a newly created *copy* of the value.
7282  */
7283 
7284 SV *
7285 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
7286 {
7287     dVAR;
7288     SV *sv = NULL;
7289 
7290     if (PL_madskills)
7291 	return NULL;
7292 
7293     if (!o)
7294 	return NULL;
7295 
7296     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
7297 	o = cLISTOPo->op_first->op_sibling;
7298 
7299     for (; o; o = o->op_next) {
7300 	const OPCODE type = o->op_type;
7301 
7302 	if (sv && o->op_next == o)
7303 	    return sv;
7304 	if (o->op_next != o) {
7305 	    if (type == OP_NEXTSTATE
7306 	     || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
7307 	     || type == OP_PUSHMARK)
7308 		continue;
7309 	    if (type == OP_DBSTATE)
7310 		continue;
7311 	}
7312 	if (type == OP_LEAVESUB || type == OP_RETURN)
7313 	    break;
7314 	if (sv)
7315 	    return NULL;
7316 	if (type == OP_CONST && cSVOPo->op_sv)
7317 	    sv = cSVOPo->op_sv;
7318 	else if (cv && type == OP_CONST) {
7319 	    sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
7320 	    if (!sv)
7321 		return NULL;
7322 	}
7323 	else if (cv && type == OP_PADSV) {
7324 	    if (CvCONST(cv)) { /* newly cloned anon */
7325 		sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
7326 		/* the candidate should have 1 ref from this pad and 1 ref
7327 		 * from the parent */
7328 		if (!sv || SvREFCNT(sv) != 2)
7329 		    return NULL;
7330 		sv = newSVsv(sv);
7331 		SvREADONLY_on(sv);
7332 		return sv;
7333 	    }
7334 	    else {
7335 		if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
7336 		    sv = &PL_sv_undef; /* an arbitrary non-null value */
7337 	    }
7338 	}
7339 	else {
7340 	    return NULL;
7341 	}
7342     }
7343     return sv;
7344 }
7345 
7346 static bool
7347 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
7348 			PADNAME * const name, SV ** const const_svp)
7349 {
7350     assert (cv);
7351     assert (o || name);
7352     assert (const_svp);
7353     if ((!block
7354 #ifdef PERL_MAD
7355 	 || block->op_type == OP_NULL
7356 #endif
7357 	 )) {
7358 	if (CvFLAGS(PL_compcv)) {
7359 	    /* might have had built-in attrs applied */
7360 	    const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
7361 	    if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
7362 	     && ckWARN(WARN_MISC))
7363 	    {
7364 		/* protect against fatal warnings leaking compcv */
7365 		SAVEFREESV(PL_compcv);
7366 		Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
7367 		SvREFCNT_inc_simple_void_NN(PL_compcv);
7368 	    }
7369 	    CvFLAGS(cv) |=
7370 		(CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
7371 		  & ~(CVf_LVALUE * pureperl));
7372 	}
7373 	return FALSE;
7374     }
7375 
7376     /* redundant check for speed: */
7377     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
7378 	const line_t oldline = CopLINE(PL_curcop);
7379 	SV *namesv = o
7380 	    ? cSVOPo->op_sv
7381 	    : sv_2mortal(newSVpvn_utf8(
7382 		PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
7383 	      ));
7384 	if (PL_parser && PL_parser->copline != NOLINE)
7385             /* This ensures that warnings are reported at the first
7386                line of a redefinition, not the last.  */
7387 	    CopLINE_set(PL_curcop, PL_parser->copline);
7388 	/* protect against fatal warnings leaking compcv */
7389 	SAVEFREESV(PL_compcv);
7390 	report_redefined_cv(namesv, cv, const_svp);
7391 	SvREFCNT_inc_simple_void_NN(PL_compcv);
7392 	CopLINE_set(PL_curcop, oldline);
7393     }
7394 #ifdef PERL_MAD
7395     if (!PL_minus_c)	/* keep old one around for madskills */
7396 #endif
7397     {
7398 	/* (PL_madskills unset in used file.) */
7399 	SAVEFREESV(cv);
7400     }
7401     return TRUE;
7402 }
7403 
7404 CV *
7405 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
7406 {
7407     dVAR;
7408     CV **spot;
7409     SV **svspot;
7410     const char *ps;
7411     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7412     U32 ps_utf8 = 0;
7413     CV *cv = NULL;
7414     CV *compcv = PL_compcv;
7415     SV *const_sv;
7416     PADNAME *name;
7417     PADOFFSET pax = o->op_targ;
7418     CV *outcv = CvOUTSIDE(PL_compcv);
7419     CV *clonee = NULL;
7420     HEK *hek = NULL;
7421     bool reusable = FALSE;
7422 
7423     PERL_ARGS_ASSERT_NEWMYSUB;
7424 
7425     /* Find the pad slot for storing the new sub.
7426        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
7427        need to look in CvOUTSIDE and find the pad belonging to the enclos-
7428        ing sub.  And then we need to dig deeper if this is a lexical from
7429        outside, as in:
7430 	   my sub foo; sub { sub foo { } }
7431      */
7432    redo:
7433     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
7434     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
7435 	pax = PARENT_PAD_INDEX(name);
7436 	outcv = CvOUTSIDE(outcv);
7437 	assert(outcv);
7438 	goto redo;
7439     }
7440     svspot =
7441 	&PadARRAY(PadlistARRAY(CvPADLIST(outcv))
7442 			[CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
7443     spot = (CV **)svspot;
7444 
7445     if (!(PL_parser && PL_parser->error_count))
7446         move_proto_attr(&proto, &attrs, (GV *)name);
7447 
7448     if (proto) {
7449 	assert(proto->op_type == OP_CONST);
7450 	ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7451         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7452     }
7453     else
7454 	ps = NULL;
7455 
7456     if (!PL_madskills) {
7457 	if (proto)
7458 	    SAVEFREEOP(proto);
7459 	if (attrs)
7460 	    SAVEFREEOP(attrs);
7461     }
7462 
7463     if (PL_parser && PL_parser->error_count) {
7464 	op_free(block);
7465 	SvREFCNT_dec(PL_compcv);
7466 	PL_compcv = 0;
7467 	goto done;
7468     }
7469 
7470     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7471 	cv = *spot;
7472 	svspot = (SV **)(spot = &clonee);
7473     }
7474     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
7475 	cv = *spot;
7476     else {
7477 	MAGIC *mg;
7478 	SvUPGRADE(name, SVt_PVMG);
7479 	mg = mg_find(name, PERL_MAGIC_proto);
7480 	assert (SvTYPE(*spot) == SVt_PVCV);
7481 	if (CvNAMED(*spot))
7482 	    hek = CvNAME_HEK(*spot);
7483 	else {
7484 	    CvNAME_HEK_set(*spot, hek =
7485 		share_hek(
7486 		    PadnamePV(name)+1,
7487 		    PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
7488 		)
7489 	    );
7490 	}
7491 	if (mg) {
7492 	    assert(mg->mg_obj);
7493 	    cv = (CV *)mg->mg_obj;
7494 	}
7495 	else {
7496 	    sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
7497 	    mg = mg_find(name, PERL_MAGIC_proto);
7498 	}
7499 	spot = (CV **)(svspot = &mg->mg_obj);
7500     }
7501 
7502     if (!block || !ps || *ps || attrs
7503 	|| (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
7504 #ifdef PERL_MAD
7505 	|| block->op_type == OP_NULL
7506 #endif
7507 	)
7508 	const_sv = NULL;
7509     else
7510 	const_sv = op_const_sv(block, NULL);
7511 
7512     if (cv) {
7513         const bool exists = CvROOT(cv) || CvXSUB(cv);
7514 
7515         /* if the subroutine doesn't exist and wasn't pre-declared
7516          * with a prototype, assume it will be AUTOLOADed,
7517          * skipping the prototype check
7518          */
7519         if (exists || SvPOK(cv))
7520             cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
7521 	/* already defined? */
7522 	if (exists) {
7523 	    if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv))
7524 		cv = NULL;
7525 	    else {
7526 		if (attrs) goto attrs;
7527 		/* just a "sub foo;" when &foo is already defined */
7528 		SAVEFREESV(compcv);
7529 		goto done;
7530 	    }
7531 	}
7532 	else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
7533 	    cv = NULL;
7534 	    reusable = TRUE;
7535 	}
7536     }
7537     if (const_sv) {
7538 	SvREFCNT_inc_simple_void_NN(const_sv);
7539 	SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7540 	if (cv) {
7541 	    assert(!CvROOT(cv) && !CvCONST(cv));
7542 	    cv_forget_slab(cv);
7543 	}
7544 	else {
7545 	    cv = MUTABLE_CV(newSV_type(SVt_PVCV));
7546 	    CvFILE_set_from_cop(cv, PL_curcop);
7547 	    CvSTASH_set(cv, PL_curstash);
7548 	    *spot = cv;
7549 	}
7550 	sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7551 	CvXSUBANY(cv).any_ptr = const_sv;
7552 	CvXSUB(cv) = const_sv_xsub;
7553 	CvCONST_on(cv);
7554 	CvISXSUB_on(cv);
7555 	if (PL_madskills)
7556 	    goto install_block;
7557 	op_free(block);
7558 	SvREFCNT_dec(compcv);
7559 	PL_compcv = NULL;
7560 	goto setname;
7561     }
7562     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
7563        determine whether this sub definition is in the same scope as its
7564        declaration.  If this sub definition is inside an inner named pack-
7565        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
7566        the package sub.  So check PadnameOUTER(name) too.
7567      */
7568     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
7569 	assert(!CvWEAKOUTSIDE(compcv));
7570 	SvREFCNT_dec(CvOUTSIDE(compcv));
7571 	CvWEAKOUTSIDE_on(compcv);
7572     }
7573     /* XXX else do we have a circular reference? */
7574     if (cv) {	/* must reuse cv in case stub is referenced elsewhere */
7575 	/* transfer PL_compcv to cv */
7576 	if (block
7577 #ifdef PERL_MAD
7578                   && block->op_type != OP_NULL
7579 #endif
7580 	) {
7581 	    cv_flags_t preserved_flags =
7582 		CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
7583 	    PADLIST *const temp_padl = CvPADLIST(cv);
7584 	    CV *const temp_cv = CvOUTSIDE(cv);
7585 	    const cv_flags_t other_flags =
7586 		CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7587 	    OP * const cvstart = CvSTART(cv);
7588 
7589 	    SvPOK_off(cv);
7590 	    CvFLAGS(cv) =
7591 		CvFLAGS(compcv) | preserved_flags;
7592 	    CvOUTSIDE(cv) = CvOUTSIDE(compcv);
7593 	    CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
7594 	    CvPADLIST(cv) = CvPADLIST(compcv);
7595 	    CvOUTSIDE(compcv) = temp_cv;
7596 	    CvPADLIST(compcv) = temp_padl;
7597 	    CvSTART(cv) = CvSTART(compcv);
7598 	    CvSTART(compcv) = cvstart;
7599 	    CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7600 	    CvFLAGS(compcv) |= other_flags;
7601 
7602 	    if (CvFILE(cv) && CvDYNFILE(cv)) {
7603 		Safefree(CvFILE(cv));
7604 	    }
7605 
7606 	    /* inner references to compcv must be fixed up ... */
7607 	    pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
7608 	    if (PERLDB_INTER)/* Advice debugger on the new sub. */
7609 	      ++PL_sub_generation;
7610 	}
7611 	else {
7612 	    /* Might have had built-in attributes applied -- propagate them. */
7613 	    CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
7614 	}
7615 	/* ... before we throw it away */
7616 	SvREFCNT_dec(compcv);
7617 	PL_compcv = compcv = cv;
7618     }
7619     else {
7620 	cv = compcv;
7621 	*spot = cv;
7622     }
7623    setname:
7624     if (!CvNAME_HEK(cv)) {
7625 	CvNAME_HEK_set(cv,
7626 	 hek
7627 	  ? share_hek_hek(hek)
7628 	  : share_hek(PadnamePV(name)+1,
7629 		      PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
7630 		      0)
7631 	);
7632     }
7633     if (const_sv) goto clone;
7634 
7635     CvFILE_set_from_cop(cv, PL_curcop);
7636     CvSTASH_set(cv, PL_curstash);
7637 
7638     if (ps) {
7639 	sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7640         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
7641     }
7642 
7643  install_block:
7644     if (!block)
7645 	goto attrs;
7646 
7647     /* If we assign an optree to a PVCV, then we've defined a subroutine that
7648        the debugger could be able to set a breakpoint in, so signal to
7649        pp_entereval that it should not throw away any saved lines at scope
7650        exit.  */
7651 
7652     PL_breakable_sub_gen++;
7653     /* This makes sub {}; work as expected.  */
7654     if (block->op_type == OP_STUB) {
7655 	    OP* const newblock = newSTATEOP(0, NULL, 0);
7656 #ifdef PERL_MAD
7657 	    op_getmad(block,newblock,'B');
7658 #else
7659 	    op_free(block);
7660 #endif
7661 	    block = newblock;
7662     }
7663     CvROOT(cv) = CvLVALUE(cv)
7664 		   ? newUNOP(OP_LEAVESUBLV, 0,
7665 			     op_lvalue(scalarseq(block), OP_LEAVESUBLV))
7666 		   : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
7667     CvROOT(cv)->op_private |= OPpREFCOUNTED;
7668     OpREFCNT_set(CvROOT(cv), 1);
7669     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
7670        itself has a refcount. */
7671     CvSLABBED_off(cv);
7672     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
7673     CvSTART(cv) = LINKLIST(CvROOT(cv));
7674     CvROOT(cv)->op_next = 0;
7675     CALL_PEEP(CvSTART(cv));
7676     finalize_optree(CvROOT(cv));
7677     S_prune_chain_head(aTHX_ &CvSTART(cv));
7678 
7679     /* now that optimizer has done its work, adjust pad values */
7680 
7681     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
7682 
7683     if (CvCLONE(cv)) {
7684 	assert(!CvCONST(cv));
7685 	if (ps && !*ps && op_const_sv(block, cv))
7686 	    CvCONST_on(cv);
7687     }
7688 
7689   attrs:
7690     if (attrs) {
7691 	/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
7692 	apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
7693     }
7694 
7695     if (block) {
7696 	if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
7697 	    SV * const tmpstr = sv_newmortal();
7698 	    GV * const db_postponed = gv_fetchpvs("DB::postponed",
7699 						  GV_ADDMULTI, SVt_PVHV);
7700 	    HV *hv;
7701 	    SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
7702 					  CopFILE(PL_curcop),
7703 					  (long)PL_subline,
7704 					  (long)CopLINE(PL_curcop));
7705 	    if (HvNAME_HEK(PL_curstash)) {
7706 		sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
7707 		sv_catpvs(tmpstr, "::");
7708 	    }
7709 	    else sv_setpvs(tmpstr, "__ANON__::");
7710 	    sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
7711 			    PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
7712 	    (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
7713 		    SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
7714 	    hv = GvHVn(db_postponed);
7715 	    if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
7716 		CV * const pcv = GvCV(db_postponed);
7717 		if (pcv) {
7718 		    dSP;
7719 		    PUSHMARK(SP);
7720 		    XPUSHs(tmpstr);
7721 		    PUTBACK;
7722 		    call_sv(MUTABLE_SV(pcv), G_DISCARD);
7723 		}
7724 	    }
7725 	}
7726     }
7727 
7728   clone:
7729     if (clonee) {
7730 	assert(CvDEPTH(outcv));
7731 	spot = (CV **)
7732 	    &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
7733 	if (reusable) cv_clone_into(clonee, *spot);
7734 	else *spot = cv_clone(clonee);
7735 	SvREFCNT_dec_NN(clonee);
7736 	cv = *spot;
7737 	SvPADMY_on(cv);
7738     }
7739     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
7740 	PADOFFSET depth = CvDEPTH(outcv);
7741 	while (--depth) {
7742 	    SV *oldcv;
7743 	    svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
7744 	    oldcv = *svspot;
7745 	    *svspot = SvREFCNT_inc_simple_NN(cv);
7746 	    SvREFCNT_dec(oldcv);
7747 	}
7748     }
7749 
7750   done:
7751     if (PL_parser)
7752 	PL_parser->copline = NOLINE;
7753     LEAVE_SCOPE(floor);
7754     if (o) op_free(o);
7755     return cv;
7756 }
7757 
7758 /* _x = extended */
7759 CV *
7760 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
7761 			    OP *block, bool o_is_gv)
7762 {
7763     dVAR;
7764     GV *gv;
7765     const char *ps;
7766     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
7767     U32 ps_utf8 = 0;
7768     CV *cv = NULL;
7769     SV *const_sv;
7770     const bool ec = PL_parser && PL_parser->error_count;
7771     /* If the subroutine has no body, no attributes, and no builtin attributes
7772        then it's just a sub declaration, and we may be able to get away with
7773        storing with a placeholder scalar in the symbol table, rather than a
7774        full GV and CV.  If anything is present then it will take a full CV to
7775        store it.  */
7776     const I32 gv_fetch_flags
7777 	= ec ? GV_NOADD_NOINIT :
7778 	 (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7779 	   || PL_madskills)
7780 	? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
7781     STRLEN namlen = 0;
7782     const char * const name =
7783 	 o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
7784     bool has_name;
7785     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
7786 #ifdef PERL_DEBUG_READONLY_OPS
7787     OPSLAB *slab = NULL;
7788 #endif
7789 
7790     if (o_is_gv) {
7791 	gv = (GV*)o;
7792 	o = NULL;
7793 	has_name = TRUE;
7794     } else if (name) {
7795 	gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
7796 	has_name = TRUE;
7797     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
7798 	SV * const sv = sv_newmortal();
7799 	Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
7800 		       PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
7801 		       CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7802 	gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
7803 	has_name = TRUE;
7804     } else if (PL_curstash) {
7805 	gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
7806 	has_name = FALSE;
7807     } else {
7808 	gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
7809 	has_name = FALSE;
7810     }
7811 
7812     if (!ec)
7813         move_proto_attr(&proto, &attrs, gv);
7814 
7815     if (proto) {
7816 	assert(proto->op_type == OP_CONST);
7817 	ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
7818         ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
7819     }
7820     else
7821 	ps = NULL;
7822 
7823     if (!PL_madskills) {
7824 	if (o)
7825 	    SAVEFREEOP(o);
7826 	if (proto)
7827 	    SAVEFREEOP(proto);
7828 	if (attrs)
7829 	    SAVEFREEOP(attrs);
7830     }
7831 
7832     if (ec) {
7833 	op_free(block);
7834 	if (name) SvREFCNT_dec(PL_compcv);
7835 	else cv = PL_compcv;
7836 	PL_compcv = 0;
7837 	if (name && block) {
7838 	    const char *s = strrchr(name, ':');
7839 	    s = s ? s+1 : name;
7840 	    if (strEQ(s, "BEGIN")) {
7841 		if (PL_in_eval & EVAL_KEEPERR)
7842 		    Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
7843 		else {
7844                     SV * const errsv = ERRSV;
7845 		    /* force display of errors found but not reported */
7846 		    sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
7847 		    Perl_croak_nocontext("%"SVf, SVfARG(errsv));
7848 		}
7849 	    }
7850 	}
7851 	goto done;
7852     }
7853 
7854     if (SvTYPE(gv) != SVt_PVGV) {	/* Maybe prototype now, and had at
7855 					   maximum a prototype before. */
7856 	if (SvTYPE(gv) > SVt_NULL) {
7857 	    cv_ckproto_len_flags((const CV *)gv,
7858 				 o ? (const GV *)cSVOPo->op_sv : NULL, ps,
7859 				 ps_len, ps_utf8);
7860 	}
7861 	if (ps) {
7862 	    sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
7863             if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
7864         }
7865 	else
7866 	    sv_setiv(MUTABLE_SV(gv), -1);
7867 
7868 	SvREFCNT_dec(PL_compcv);
7869 	cv = PL_compcv = NULL;
7870 	goto done;
7871     }
7872 
7873     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
7874 
7875     if (!block || !ps || *ps || attrs
7876 	|| (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
7877 #ifdef PERL_MAD
7878 	|| block->op_type == OP_NULL
7879 #endif
7880 	)
7881 	const_sv = NULL;
7882     else
7883 	const_sv = op_const_sv(block, NULL);
7884 
7885     if (cv) {
7886         const bool exists = CvROOT(cv) || CvXSUB(cv);
7887 
7888         /* if the subroutine doesn't exist and wasn't pre-declared
7889          * with a prototype, assume it will be AUTOLOADed,
7890          * skipping the prototype check
7891          */
7892         if (exists || SvPOK(cv))
7893             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
7894 	/* already defined (or promised)? */
7895 	if (exists || GvASSUMECV(gv)) {
7896 	    if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
7897 		cv = NULL;
7898 	    else {
7899 		if (attrs) goto attrs;
7900 		/* just a "sub foo;" when &foo is already defined */
7901 		SAVEFREESV(PL_compcv);
7902 		goto done;
7903 	    }
7904 	}
7905     }
7906     if (const_sv) {
7907 	SvREFCNT_inc_simple_void_NN(const_sv);
7908 	SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
7909 	if (cv) {
7910 	    assert(!CvROOT(cv) && !CvCONST(cv));
7911 	    cv_forget_slab(cv);
7912 	    sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
7913 	    CvXSUBANY(cv).any_ptr = const_sv;
7914 	    CvXSUB(cv) = const_sv_xsub;
7915 	    CvCONST_on(cv);
7916 	    CvISXSUB_on(cv);
7917 	}
7918 	else {
7919 	    GvCV_set(gv, NULL);
7920 	    cv = newCONSTSUB_flags(
7921 		NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
7922 		const_sv
7923 	    );
7924 	}
7925 	if (PL_madskills)
7926 	    goto install_block;
7927 	op_free(block);
7928 	SvREFCNT_dec(PL_compcv);
7929 	PL_compcv = NULL;
7930 	goto done;
7931     }
7932     if (cv) {				/* must reuse cv if autoloaded */
7933 	/* transfer PL_compcv to cv */
7934 	if (block
7935 #ifdef PERL_MAD
7936                   && block->op_type != OP_NULL
7937 #endif
7938 	) {
7939 	    cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
7940 	    PADLIST *const temp_av = CvPADLIST(cv);
7941 	    CV *const temp_cv = CvOUTSIDE(cv);
7942 	    const cv_flags_t other_flags =
7943 		CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
7944 	    OP * const cvstart = CvSTART(cv);
7945 
7946 	    CvGV_set(cv,gv);
7947 	    assert(!CvCVGV_RC(cv));
7948 	    assert(CvGV(cv) == gv);
7949 
7950 	    SvPOK_off(cv);
7951 	    CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
7952 	    CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
7953 	    CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
7954 	    CvPADLIST(cv) = CvPADLIST(PL_compcv);
7955 	    CvOUTSIDE(PL_compcv) = temp_cv;
7956 	    CvPADLIST(PL_compcv) = temp_av;
7957 	    CvSTART(cv) = CvSTART(PL_compcv);
7958 	    CvSTART(PL_compcv) = cvstart;
7959 	    CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
7960 	    CvFLAGS(PL_compcv) |= other_flags;
7961 
7962 	    if (CvFILE(cv) && CvDYNFILE(cv)) {
7963 		Safefree(CvFILE(cv));
7964     }
7965 	    CvFILE_set_from_cop(cv, PL_curcop);
7966 	    CvSTASH_set(cv, PL_curstash);
7967 
7968 	    /* inner references to PL_compcv must be fixed up ... */
7969 	    pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
7970 	    if (PERLDB_INTER)/* Advice debugger on the new sub. */
7971 	      ++PL_sub_generation;
7972 	}
7973 	else {
7974 	    /* Might have had built-in attributes applied -- propagate them. */
7975 	    CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
7976 	}
7977 	/* ... before we throw it away */
7978 	SvREFCNT_dec(PL_compcv);
7979 	PL_compcv = cv;
7980     }
7981     else {
7982 	cv = PL_compcv;
7983 	if (name) {
7984 	    GvCV_set(gv, cv);
7985 	    GvCVGEN(gv) = 0;
7986 	    if (HvENAME_HEK(GvSTASH(gv)))
7987 		/* sub Foo::bar { (shift)+1 } */
7988 		gv_method_changed(gv);
7989 	}
7990     }
7991     if (!CvGV(cv)) {
7992 	CvGV_set(cv, gv);
7993 	CvFILE_set_from_cop(cv, PL_curcop);
7994 	CvSTASH_set(cv, PL_curstash);
7995     }
7996 
7997     if (ps) {
7998 	sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
7999         if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
8000     }
8001 
8002  install_block:
8003     if (!block)
8004 	goto attrs;
8005 
8006     /* If we assign an optree to a PVCV, then we've defined a subroutine that
8007        the debugger could be able to set a breakpoint in, so signal to
8008        pp_entereval that it should not throw away any saved lines at scope
8009        exit.  */
8010 
8011     PL_breakable_sub_gen++;
8012     /* This makes sub {}; work as expected.  */
8013     if (block->op_type == OP_STUB) {
8014 	    OP* const newblock = newSTATEOP(0, NULL, 0);
8015 #ifdef PERL_MAD
8016 	    op_getmad(block,newblock,'B');
8017 #else
8018 	    op_free(block);
8019 #endif
8020 	    block = newblock;
8021     }
8022     CvROOT(cv) = CvLVALUE(cv)
8023 		   ? newUNOP(OP_LEAVESUBLV, 0,
8024 			     op_lvalue(scalarseq(block), OP_LEAVESUBLV))
8025 		   : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
8026     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8027     OpREFCNT_set(CvROOT(cv), 1);
8028     /* The cv no longer needs to hold a refcount on the slab, as CvROOT
8029        itself has a refcount. */
8030     CvSLABBED_off(cv);
8031     OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
8032 #ifdef PERL_DEBUG_READONLY_OPS
8033     slab = (OPSLAB *)CvSTART(cv);
8034 #endif
8035     CvSTART(cv) = LINKLIST(CvROOT(cv));
8036     CvROOT(cv)->op_next = 0;
8037     CALL_PEEP(CvSTART(cv));
8038     finalize_optree(CvROOT(cv));
8039     S_prune_chain_head(aTHX_ &CvSTART(cv));
8040 
8041     /* now that optimizer has done its work, adjust pad values */
8042 
8043     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
8044 
8045     if (CvCLONE(cv)) {
8046 	assert(!CvCONST(cv));
8047 	if (ps && !*ps && op_const_sv(block, cv))
8048 	    CvCONST_on(cv);
8049     }
8050 
8051   attrs:
8052     if (attrs) {
8053 	/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
8054 	HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
8055 	if (!name) SAVEFREESV(cv);
8056 	apply_attrs(stash, MUTABLE_SV(cv), attrs);
8057 	if (!name) SvREFCNT_inc_simple_void_NN(cv);
8058     }
8059 
8060     if (block && has_name) {
8061 	if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
8062 	    SV * const tmpstr = sv_newmortal();
8063 	    GV * const db_postponed = gv_fetchpvs("DB::postponed",
8064 						  GV_ADDMULTI, SVt_PVHV);
8065 	    HV *hv;
8066 	    SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
8067 					  CopFILE(PL_curcop),
8068 					  (long)PL_subline,
8069 					  (long)CopLINE(PL_curcop));
8070 	    gv_efullname3(tmpstr, gv, NULL);
8071 	    (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
8072 		    SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
8073 	    hv = GvHVn(db_postponed);
8074 	    if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
8075 		CV * const pcv = GvCV(db_postponed);
8076 		if (pcv) {
8077 		    dSP;
8078 		    PUSHMARK(SP);
8079 		    XPUSHs(tmpstr);
8080 		    PUTBACK;
8081 		    call_sv(MUTABLE_SV(pcv), G_DISCARD);
8082 		}
8083 	    }
8084 	}
8085 
8086 	if (name && ! (PL_parser && PL_parser->error_count))
8087 	    process_special_blocks(floor, name, gv, cv);
8088     }
8089 
8090   done:
8091     if (PL_parser)
8092 	PL_parser->copline = NOLINE;
8093     LEAVE_SCOPE(floor);
8094 #ifdef PERL_DEBUG_READONLY_OPS
8095     /* Watch out for BEGIN blocks */
8096     if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab);
8097 #endif
8098     return cv;
8099 }
8100 
8101 STATIC void
8102 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
8103 			 GV *const gv,
8104 			 CV *const cv)
8105 {
8106     const char *const colon = strrchr(fullname,':');
8107     const char *const name = colon ? colon + 1 : fullname;
8108 
8109     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
8110 
8111     if (*name == 'B') {
8112 	if (strEQ(name, "BEGIN")) {
8113 	    const I32 oldscope = PL_scopestack_ix;
8114             dSP;
8115 	    if (floor) LEAVE_SCOPE(floor);
8116 	    ENTER;
8117             PUSHSTACKi(PERLSI_REQUIRE);
8118 	    SAVECOPFILE(&PL_compiling);
8119 	    SAVECOPLINE(&PL_compiling);
8120 	    SAVEVPTR(PL_curcop);
8121 
8122 	    DEBUG_x( dump_sub(gv) );
8123 	    Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
8124 	    GvCV_set(gv,0);		/* cv has been hijacked */
8125 	    call_list(oldscope, PL_beginav);
8126 
8127             POPSTACK;
8128 	    LEAVE;
8129 	}
8130 	else
8131 	    return;
8132     } else {
8133 	if (*name == 'E') {
8134 	    if strEQ(name, "END") {
8135 		DEBUG_x( dump_sub(gv) );
8136 		Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
8137 	    } else
8138 		return;
8139 	} else if (*name == 'U') {
8140 	    if (strEQ(name, "UNITCHECK")) {
8141 		/* It's never too late to run a unitcheck block */
8142 		Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
8143 	    }
8144 	    else
8145 		return;
8146 	} else if (*name == 'C') {
8147 	    if (strEQ(name, "CHECK")) {
8148 		if (PL_main_start)
8149 		    /* diag_listed_as: Too late to run %s block */
8150 		    Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8151 				   "Too late to run CHECK block");
8152 		Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
8153 	    }
8154 	    else
8155 		return;
8156 	} else if (*name == 'I') {
8157 	    if (strEQ(name, "INIT")) {
8158 		if (PL_main_start)
8159 		    /* diag_listed_as: Too late to run %s block */
8160 		    Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
8161 				   "Too late to run INIT block");
8162 		Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
8163 	    }
8164 	    else
8165 		return;
8166 	} else
8167 	    return;
8168 	DEBUG_x( dump_sub(gv) );
8169 	GvCV_set(gv,0);		/* cv has been hijacked */
8170     }
8171 }
8172 
8173 /*
8174 =for apidoc newCONSTSUB
8175 
8176 See L</newCONSTSUB_flags>.
8177 
8178 =cut
8179 */
8180 
8181 CV *
8182 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
8183 {
8184     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
8185 }
8186 
8187 /*
8188 =for apidoc newCONSTSUB_flags
8189 
8190 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
8191 eligible for inlining at compile-time.
8192 
8193 Currently, the only useful value for C<flags> is SVf_UTF8.
8194 
8195 The newly created subroutine takes ownership of a reference to the passed in
8196 SV.
8197 
8198 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
8199 which won't be called if used as a destructor, but will suppress the overhead
8200 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
8201 compile time.)
8202 
8203 =cut
8204 */
8205 
8206 CV *
8207 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
8208                              U32 flags, SV *sv)
8209 {
8210     dVAR;
8211     CV* cv;
8212     const char *const file = CopFILE(PL_curcop);
8213 
8214     ENTER;
8215 
8216     if (IN_PERL_RUNTIME) {
8217 	/* at runtime, it's not safe to manipulate PL_curcop: it may be
8218 	 * an op shared between threads. Use a non-shared COP for our
8219 	 * dirty work */
8220 	 SAVEVPTR(PL_curcop);
8221 	 SAVECOMPILEWARNINGS();
8222 	 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8223 	 PL_curcop = &PL_compiling;
8224     }
8225     SAVECOPLINE(PL_curcop);
8226     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
8227 
8228     SAVEHINTS();
8229     PL_hints &= ~HINT_BLOCK_SCOPE;
8230 
8231     if (stash) {
8232 	SAVEGENERICSV(PL_curstash);
8233 	PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
8234     }
8235 
8236     /* Protect sv against leakage caused by fatal warnings. */
8237     if (sv) SAVEFREESV(sv);
8238 
8239     /* file becomes the CvFILE. For an XS, it's usually static storage,
8240        and so doesn't get free()d.  (It's expected to be from the C pre-
8241        processor __FILE__ directive). But we need a dynamically allocated one,
8242        and we need it to get freed.  */
8243     cv = newXS_len_flags(name, len,
8244 			 sv && SvTYPE(sv) == SVt_PVAV
8245 			     ? const_av_xsub
8246 			     : const_sv_xsub,
8247 			 file ? file : "", "",
8248 			 &sv, XS_DYNAMIC_FILENAME | flags);
8249     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
8250     CvCONST_on(cv);
8251 
8252     LEAVE;
8253 
8254     return cv;
8255 }
8256 
8257 CV *
8258 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
8259 		 const char *const filename, const char *const proto,
8260 		 U32 flags)
8261 {
8262     PERL_ARGS_ASSERT_NEWXS_FLAGS;
8263     return newXS_len_flags(
8264        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
8265     );
8266 }
8267 
8268 CV *
8269 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
8270 			   XSUBADDR_t subaddr, const char *const filename,
8271 			   const char *const proto, SV **const_svp,
8272 			   U32 flags)
8273 {
8274     CV *cv;
8275     bool interleave = FALSE;
8276 
8277     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
8278 
8279     {
8280         GV * const gv = gv_fetchpvn(
8281 			    name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
8282 			    name ? len : PL_curstash ? sizeof("__ANON__") - 1:
8283 				sizeof("__ANON__::__ANON__") - 1,
8284 			    GV_ADDMULTI | flags, SVt_PVCV);
8285 
8286         if (!subaddr)
8287             Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
8288 
8289         if ((cv = (name ? GvCV(gv) : NULL))) {
8290             if (GvCVGEN(gv)) {
8291                 /* just a cached method */
8292                 SvREFCNT_dec(cv);
8293                 cv = NULL;
8294             }
8295             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
8296                 /* already defined (or promised) */
8297                 /* Redundant check that allows us to avoid creating an SV
8298                    most of the time: */
8299                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
8300                     report_redefined_cv(newSVpvn_flags(
8301                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
8302                                         ),
8303                                         cv, const_svp);
8304                 }
8305                 interleave = TRUE;
8306                 ENTER;
8307                 SAVEFREESV(cv);
8308                 cv = NULL;
8309             }
8310         }
8311 
8312         if (cv)				/* must reuse cv if autoloaded */
8313             cv_undef(cv);
8314         else {
8315             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8316             if (name) {
8317                 GvCV_set(gv,cv);
8318                 GvCVGEN(gv) = 0;
8319                 if (HvENAME_HEK(GvSTASH(gv)))
8320                     gv_method_changed(gv); /* newXS */
8321             }
8322         }
8323         if (!name)
8324             CvANON_on(cv);
8325         CvGV_set(cv, gv);
8326         (void)gv_fetchfile(filename);
8327         CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
8328                                     an external constant string */
8329         assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
8330         CvISXSUB_on(cv);
8331         CvXSUB(cv) = subaddr;
8332 
8333         if (name)
8334             process_special_blocks(0, name, gv, cv);
8335     }
8336 
8337     if (flags & XS_DYNAMIC_FILENAME) {
8338 	CvFILE(cv) = savepv(filename);
8339 	CvDYNFILE_on(cv);
8340     }
8341     sv_setpv(MUTABLE_SV(cv), proto);
8342     if (interleave) LEAVE;
8343     return cv;
8344 }
8345 
8346 CV *
8347 Perl_newSTUB(pTHX_ GV *gv, bool fake)
8348 {
8349     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
8350     GV *cvgv;
8351     PERL_ARGS_ASSERT_NEWSTUB;
8352     assert(!GvCVu(gv));
8353     GvCV_set(gv, cv);
8354     GvCVGEN(gv) = 0;
8355     if (!fake && HvENAME_HEK(GvSTASH(gv)))
8356 	gv_method_changed(gv);
8357     if (SvFAKE(gv)) {
8358 	cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
8359 	SvFAKE_off(cvgv);
8360     }
8361     else cvgv = gv;
8362     CvGV_set(cv, cvgv);
8363     CvFILE_set_from_cop(cv, PL_curcop);
8364     CvSTASH_set(cv, PL_curstash);
8365     GvMULTI_on(gv);
8366     return cv;
8367 }
8368 
8369 /*
8370 =for apidoc U||newXS
8371 
8372 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
8373 static storage, as it is used directly as CvFILE(), without a copy being made.
8374 
8375 =cut
8376 */
8377 
8378 CV *
8379 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
8380 {
8381     PERL_ARGS_ASSERT_NEWXS;
8382     return newXS_len_flags(
8383 	name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
8384     );
8385 }
8386 
8387 #ifdef PERL_MAD
8388 OP *
8389 #else
8390 void
8391 #endif
8392 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
8393 {
8394     dVAR;
8395     CV *cv;
8396 #ifdef PERL_MAD
8397     OP* pegop = newOP(OP_NULL, 0);
8398 #endif
8399 
8400     GV *gv;
8401 
8402     if (PL_parser && PL_parser->error_count) {
8403 	op_free(block);
8404 	goto finish;
8405     }
8406 
8407     gv = o
8408 	? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
8409 	: gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
8410 
8411     GvMULTI_on(gv);
8412     if ((cv = GvFORM(gv))) {
8413 	if (ckWARN(WARN_REDEFINE)) {
8414 	    const line_t oldline = CopLINE(PL_curcop);
8415 	    if (PL_parser && PL_parser->copline != NOLINE)
8416 		CopLINE_set(PL_curcop, PL_parser->copline);
8417 	    if (o) {
8418 		Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8419 			    "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
8420 	    } else {
8421 		/* diag_listed_as: Format %s redefined */
8422 		Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
8423 			    "Format STDOUT redefined");
8424 	    }
8425 	    CopLINE_set(PL_curcop, oldline);
8426 	}
8427 	SvREFCNT_dec(cv);
8428     }
8429     cv = PL_compcv;
8430     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
8431     CvGV_set(cv, gv);
8432     CvFILE_set_from_cop(cv, PL_curcop);
8433 
8434 
8435     pad_tidy(padtidy_FORMAT);
8436     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
8437     CvROOT(cv)->op_private |= OPpREFCOUNTED;
8438     OpREFCNT_set(CvROOT(cv), 1);
8439     CvSTART(cv) = LINKLIST(CvROOT(cv));
8440     CvROOT(cv)->op_next = 0;
8441     CALL_PEEP(CvSTART(cv));
8442     finalize_optree(CvROOT(cv));
8443     S_prune_chain_head(aTHX_ &CvSTART(cv));
8444     cv_forget_slab(cv);
8445 
8446   finish:
8447 #ifdef PERL_MAD
8448     op_getmad(o,pegop,'n');
8449     op_getmad_weak(block, pegop, 'b');
8450 #else
8451     op_free(o);
8452 #endif
8453     if (PL_parser)
8454 	PL_parser->copline = NOLINE;
8455     LEAVE_SCOPE(floor);
8456 #ifdef PERL_MAD
8457     return pegop;
8458 #endif
8459 }
8460 
8461 OP *
8462 Perl_newANONLIST(pTHX_ OP *o)
8463 {
8464     return convert(OP_ANONLIST, OPf_SPECIAL, o);
8465 }
8466 
8467 OP *
8468 Perl_newANONHASH(pTHX_ OP *o)
8469 {
8470     return convert(OP_ANONHASH, OPf_SPECIAL, o);
8471 }
8472 
8473 OP *
8474 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
8475 {
8476     return newANONATTRSUB(floor, proto, NULL, block);
8477 }
8478 
8479 OP *
8480 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
8481 {
8482     return newUNOP(OP_REFGEN, 0,
8483 	newSVOP(OP_ANONCODE, 0,
8484 		MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
8485 }
8486 
8487 OP *
8488 Perl_oopsAV(pTHX_ OP *o)
8489 {
8490     dVAR;
8491 
8492     PERL_ARGS_ASSERT_OOPSAV;
8493 
8494     switch (o->op_type) {
8495     case OP_PADSV:
8496     case OP_PADHV:
8497 	o->op_type = OP_PADAV;
8498 	o->op_ppaddr = PL_ppaddr[OP_PADAV];
8499 	return ref(o, OP_RV2AV);
8500 
8501     case OP_RV2SV:
8502     case OP_RV2HV:
8503 	o->op_type = OP_RV2AV;
8504 	o->op_ppaddr = PL_ppaddr[OP_RV2AV];
8505 	ref(o, OP_RV2AV);
8506 	break;
8507 
8508     default:
8509 	Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
8510 	break;
8511     }
8512     return o;
8513 }
8514 
8515 OP *
8516 Perl_oopsHV(pTHX_ OP *o)
8517 {
8518     dVAR;
8519 
8520     PERL_ARGS_ASSERT_OOPSHV;
8521 
8522     switch (o->op_type) {
8523     case OP_PADSV:
8524     case OP_PADAV:
8525 	o->op_type = OP_PADHV;
8526 	o->op_ppaddr = PL_ppaddr[OP_PADHV];
8527 	return ref(o, OP_RV2HV);
8528 
8529     case OP_RV2SV:
8530     case OP_RV2AV:
8531 	o->op_type = OP_RV2HV;
8532 	o->op_ppaddr = PL_ppaddr[OP_RV2HV];
8533 	ref(o, OP_RV2HV);
8534 	break;
8535 
8536     default:
8537 	Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
8538 	break;
8539     }
8540     return o;
8541 }
8542 
8543 OP *
8544 Perl_newAVREF(pTHX_ OP *o)
8545 {
8546     dVAR;
8547 
8548     PERL_ARGS_ASSERT_NEWAVREF;
8549 
8550     if (o->op_type == OP_PADANY) {
8551 	o->op_type = OP_PADAV;
8552 	o->op_ppaddr = PL_ppaddr[OP_PADAV];
8553 	return o;
8554     }
8555     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
8556 	Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8557 		       "Using an array as a reference is deprecated");
8558     }
8559     return newUNOP(OP_RV2AV, 0, scalar(o));
8560 }
8561 
8562 OP *
8563 Perl_newGVREF(pTHX_ I32 type, OP *o)
8564 {
8565     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
8566 	return newUNOP(OP_NULL, 0, o);
8567     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
8568 }
8569 
8570 OP *
8571 Perl_newHVREF(pTHX_ OP *o)
8572 {
8573     dVAR;
8574 
8575     PERL_ARGS_ASSERT_NEWHVREF;
8576 
8577     if (o->op_type == OP_PADANY) {
8578 	o->op_type = OP_PADHV;
8579 	o->op_ppaddr = PL_ppaddr[OP_PADHV];
8580 	return o;
8581     }
8582     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
8583 	Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
8584 		       "Using a hash as a reference is deprecated");
8585     }
8586     return newUNOP(OP_RV2HV, 0, scalar(o));
8587 }
8588 
8589 OP *
8590 Perl_newCVREF(pTHX_ I32 flags, OP *o)
8591 {
8592     if (o->op_type == OP_PADANY) {
8593 	dVAR;
8594 	o->op_type = OP_PADCV;
8595 	o->op_ppaddr = PL_ppaddr[OP_PADCV];
8596     }
8597     return newUNOP(OP_RV2CV, flags, scalar(o));
8598 }
8599 
8600 OP *
8601 Perl_newSVREF(pTHX_ OP *o)
8602 {
8603     dVAR;
8604 
8605     PERL_ARGS_ASSERT_NEWSVREF;
8606 
8607     if (o->op_type == OP_PADANY) {
8608 	o->op_type = OP_PADSV;
8609 	o->op_ppaddr = PL_ppaddr[OP_PADSV];
8610 	return o;
8611     }
8612     return newUNOP(OP_RV2SV, 0, scalar(o));
8613 }
8614 
8615 /* Check routines. See the comments at the top of this file for details
8616  * on when these are called */
8617 
8618 OP *
8619 Perl_ck_anoncode(pTHX_ OP *o)
8620 {
8621     PERL_ARGS_ASSERT_CK_ANONCODE;
8622 
8623     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
8624     if (!PL_madskills)
8625 	cSVOPo->op_sv = NULL;
8626     return o;
8627 }
8628 
8629 static void
8630 S_io_hints(pTHX_ OP *o)
8631 {
8632     HV * const table =
8633 	PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
8634     if (table) {
8635 	SV **svp = hv_fetchs(table, "open_IN", FALSE);
8636 	if (svp && *svp) {
8637 	    STRLEN len = 0;
8638 	    const char *d = SvPV_const(*svp, len);
8639 	    const I32 mode = mode_from_discipline(d, len);
8640 	    if (mode & O_BINARY)
8641 		o->op_private |= OPpOPEN_IN_RAW;
8642 	    else if (mode & O_TEXT)
8643 		o->op_private |= OPpOPEN_IN_CRLF;
8644 	}
8645 
8646 	svp = hv_fetchs(table, "open_OUT", FALSE);
8647 	if (svp && *svp) {
8648 	    STRLEN len = 0;
8649 	    const char *d = SvPV_const(*svp, len);
8650 	    const I32 mode = mode_from_discipline(d, len);
8651 	    if (mode & O_BINARY)
8652 		o->op_private |= OPpOPEN_OUT_RAW;
8653 	    else if (mode & O_TEXT)
8654 		o->op_private |= OPpOPEN_OUT_CRLF;
8655 	}
8656     }
8657 }
8658 
8659 OP *
8660 Perl_ck_backtick(pTHX_ OP *o)
8661 {
8662     GV *gv;
8663     OP *newop = NULL;
8664     PERL_ARGS_ASSERT_CK_BACKTICK;
8665     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
8666     if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_sibling
8667      && (gv = gv_override("readpipe",8))) {
8668 	newop = S_new_entersubop(aTHX_ gv, cUNOPo->op_first->op_sibling);
8669 	cUNOPo->op_first->op_sibling = NULL;
8670     }
8671     else if (!(o->op_flags & OPf_KIDS))
8672 	newop = newUNOP(OP_BACKTICK, 0,	newDEFSVOP());
8673     if (newop) {
8674 #ifdef PERL_MAD
8675 	op_getmad(o,newop,'O');
8676 #else
8677 	op_free(o);
8678 #endif
8679 	return newop;
8680     }
8681     S_io_hints(aTHX_ o);
8682     return o;
8683 }
8684 
8685 OP *
8686 Perl_ck_bitop(pTHX_ OP *o)
8687 {
8688     dVAR;
8689 
8690     PERL_ARGS_ASSERT_CK_BITOP;
8691 
8692     o->op_private = (U8)(PL_hints & HINT_INTEGER);
8693     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
8694 	    && (o->op_type == OP_BIT_OR
8695 	     || o->op_type == OP_BIT_AND
8696 	     || o->op_type == OP_BIT_XOR))
8697     {
8698 	const OP * const left = cBINOPo->op_first;
8699 	const OP * const right = left->op_sibling;
8700 	if ((OP_IS_NUMCOMPARE(left->op_type) &&
8701 		(left->op_flags & OPf_PARENS) == 0) ||
8702 	    (OP_IS_NUMCOMPARE(right->op_type) &&
8703 		(right->op_flags & OPf_PARENS) == 0))
8704 	    Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8705 			   "Possible precedence problem on bitwise %c operator",
8706 			   o->op_type == OP_BIT_OR ? '|'
8707 			   : o->op_type == OP_BIT_AND ? '&' : '^'
8708 			   );
8709     }
8710     return o;
8711 }
8712 
8713 PERL_STATIC_INLINE bool
8714 is_dollar_bracket(pTHX_ const OP * const o)
8715 {
8716     const OP *kid;
8717     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
8718 	&& (kid = cUNOPx(o)->op_first)
8719 	&& kid->op_type == OP_GV
8720 	&& strEQ(GvNAME(cGVOPx_gv(kid)), "[");
8721 }
8722 
8723 OP *
8724 Perl_ck_cmp(pTHX_ OP *o)
8725 {
8726     PERL_ARGS_ASSERT_CK_CMP;
8727     if (ckWARN(WARN_SYNTAX)) {
8728 	const OP *kid = cUNOPo->op_first;
8729 	if (kid && (
8730 		(
8731 		   is_dollar_bracket(aTHX_ kid)
8732 		&& kid->op_sibling && kid->op_sibling->op_type == OP_CONST
8733 		)
8734 	     || (  kid->op_type == OP_CONST
8735 		&& (kid = kid->op_sibling) && is_dollar_bracket(aTHX_ kid))
8736 	   ))
8737 	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8738 			"$[ used in %s (did you mean $] ?)", OP_DESC(o));
8739     }
8740     return o;
8741 }
8742 
8743 OP *
8744 Perl_ck_concat(pTHX_ OP *o)
8745 {
8746     const OP * const kid = cUNOPo->op_first;
8747 
8748     PERL_ARGS_ASSERT_CK_CONCAT;
8749     PERL_UNUSED_CONTEXT;
8750 
8751     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
8752 	    !(kUNOP->op_first->op_flags & OPf_MOD))
8753         o->op_flags |= OPf_STACKED;
8754     return o;
8755 }
8756 
8757 OP *
8758 Perl_ck_spair(pTHX_ OP *o)
8759 {
8760     dVAR;
8761 
8762     PERL_ARGS_ASSERT_CK_SPAIR;
8763 
8764     if (o->op_flags & OPf_KIDS) {
8765 	OP* newop;
8766 	OP* kid;
8767 	const OPCODE type = o->op_type;
8768 	o = modkids(ck_fun(o), type);
8769 	kid = cUNOPo->op_first;
8770 	newop = kUNOP->op_first->op_sibling;
8771 	if (newop) {
8772 	    const OPCODE type = newop->op_type;
8773 	    if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
8774 		    type == OP_PADAV || type == OP_PADHV ||
8775 		    type == OP_RV2AV || type == OP_RV2HV)
8776 		return o;
8777 	}
8778 #ifdef PERL_MAD
8779 	op_getmad(kUNOP->op_first,newop,'K');
8780 #else
8781 	op_free(kUNOP->op_first);
8782 #endif
8783 	kUNOP->op_first = newop;
8784     }
8785     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
8786      * and OP_CHOMP into OP_SCHOMP */
8787     o->op_ppaddr = PL_ppaddr[++o->op_type];
8788     return ck_fun(o);
8789 }
8790 
8791 OP *
8792 Perl_ck_delete(pTHX_ OP *o)
8793 {
8794     PERL_ARGS_ASSERT_CK_DELETE;
8795 
8796     o = ck_fun(o);
8797     o->op_private = 0;
8798     if (o->op_flags & OPf_KIDS) {
8799 	OP * const kid = cUNOPo->op_first;
8800 	switch (kid->op_type) {
8801 	case OP_ASLICE:
8802 	    o->op_flags |= OPf_SPECIAL;
8803 	    /* FALL THROUGH */
8804 	case OP_HSLICE:
8805 	    o->op_private |= OPpSLICE;
8806 	    break;
8807 	case OP_AELEM:
8808 	    o->op_flags |= OPf_SPECIAL;
8809 	    /* FALL THROUGH */
8810 	case OP_HELEM:
8811 	    break;
8812 	case OP_KVASLICE:
8813 	    Perl_croak(aTHX_ "delete argument is index/value array slice,"
8814 			     " use array slice");
8815 	case OP_KVHSLICE:
8816 	    Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
8817 			     " hash slice");
8818 	default:
8819 	    Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
8820 			     "element or slice");
8821 	}
8822 	if (kid->op_private & OPpLVAL_INTRO)
8823 	    o->op_private |= OPpLVAL_INTRO;
8824 	op_null(kid);
8825     }
8826     return o;
8827 }
8828 
8829 OP *
8830 Perl_ck_eof(pTHX_ OP *o)
8831 {
8832     dVAR;
8833 
8834     PERL_ARGS_ASSERT_CK_EOF;
8835 
8836     if (o->op_flags & OPf_KIDS) {
8837 	OP *kid;
8838 	if (cLISTOPo->op_first->op_type == OP_STUB) {
8839 	    OP * const newop
8840 		= newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
8841 #ifdef PERL_MAD
8842 	    op_getmad(o,newop,'O');
8843 #else
8844 	    op_free(o);
8845 #endif
8846 	    o = newop;
8847 	}
8848 	o = ck_fun(o);
8849 	kid = cLISTOPo->op_first;
8850 	if (kid->op_type == OP_RV2GV)
8851 	    kid->op_private |= OPpALLOW_FAKE;
8852     }
8853     return o;
8854 }
8855 
8856 OP *
8857 Perl_ck_eval(pTHX_ OP *o)
8858 {
8859     dVAR;
8860 
8861     PERL_ARGS_ASSERT_CK_EVAL;
8862 
8863     PL_hints |= HINT_BLOCK_SCOPE;
8864     if (o->op_flags & OPf_KIDS) {
8865 	SVOP * const kid = (SVOP*)cUNOPo->op_first;
8866 	assert(kid);
8867 
8868 	if (o->op_type == OP_ENTERTRY) {
8869 	    LOGOP *enter;
8870 #ifdef PERL_MAD
8871 	    OP* const oldo = o;
8872 #endif
8873 
8874 	    cUNOPo->op_first = 0;
8875 #ifndef PERL_MAD
8876 	    op_free(o);
8877 #endif
8878 
8879 	    NewOp(1101, enter, 1, LOGOP);
8880 	    enter->op_type = OP_ENTERTRY;
8881 	    enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
8882 	    enter->op_private = 0;
8883 
8884 	    /* establish postfix order */
8885 	    enter->op_next = (OP*)enter;
8886 
8887 	    o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
8888 	    o->op_type = OP_LEAVETRY;
8889 	    o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
8890 	    enter->op_other = o;
8891 	    op_getmad(oldo,o,'O');
8892 	    return o;
8893 	}
8894 	else {
8895 	    scalar((OP*)kid);
8896 	    PL_cv_has_eval = 1;
8897 	}
8898     }
8899     else {
8900 	const U8 priv = o->op_private;
8901 #ifdef PERL_MAD
8902 	OP* const oldo = o;
8903 #else
8904 	op_free(o);
8905 #endif
8906 	o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
8907 	op_getmad(oldo,o,'O');
8908     }
8909     o->op_targ = (PADOFFSET)PL_hints;
8910     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
8911     if ((PL_hints & HINT_LOCALIZE_HH) != 0
8912      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
8913 	/* Store a copy of %^H that pp_entereval can pick up. */
8914 	OP *hhop = newSVOP(OP_HINTSEVAL, 0,
8915 			   MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
8916 	cUNOPo->op_first->op_sibling = hhop;
8917 	o->op_private |= OPpEVAL_HAS_HH;
8918     }
8919     if (!(o->op_private & OPpEVAL_BYTES)
8920 	 && FEATURE_UNIEVAL_IS_ENABLED)
8921 	    o->op_private |= OPpEVAL_UNICODE;
8922     return o;
8923 }
8924 
8925 OP *
8926 Perl_ck_exec(pTHX_ OP *o)
8927 {
8928     PERL_ARGS_ASSERT_CK_EXEC;
8929 
8930     if (o->op_flags & OPf_STACKED) {
8931         OP *kid;
8932 	o = ck_fun(o);
8933 	kid = cUNOPo->op_first->op_sibling;
8934 	if (kid->op_type == OP_RV2GV)
8935 	    op_null(kid);
8936     }
8937     else
8938 	o = listkids(o);
8939     return o;
8940 }
8941 
8942 OP *
8943 Perl_ck_exists(pTHX_ OP *o)
8944 {
8945     dVAR;
8946 
8947     PERL_ARGS_ASSERT_CK_EXISTS;
8948 
8949     o = ck_fun(o);
8950     if (o->op_flags & OPf_KIDS) {
8951 	OP * const kid = cUNOPo->op_first;
8952 	if (kid->op_type == OP_ENTERSUB) {
8953 	    (void) ref(kid, o->op_type);
8954 	    if (kid->op_type != OP_RV2CV
8955 			&& !(PL_parser && PL_parser->error_count))
8956 		Perl_croak(aTHX_
8957 			  "exists argument is not a subroutine name");
8958 	    o->op_private |= OPpEXISTS_SUB;
8959 	}
8960 	else if (kid->op_type == OP_AELEM)
8961 	    o->op_flags |= OPf_SPECIAL;
8962 	else if (kid->op_type != OP_HELEM)
8963 	    Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
8964 			     "element or a subroutine");
8965 	op_null(kid);
8966     }
8967     return o;
8968 }
8969 
8970 OP *
8971 Perl_ck_rvconst(pTHX_ OP *o)
8972 {
8973     dVAR;
8974     SVOP * const kid = (SVOP*)cUNOPo->op_first;
8975 
8976     PERL_ARGS_ASSERT_CK_RVCONST;
8977 
8978     o->op_private |= (PL_hints & HINT_STRICT_REFS);
8979     if (o->op_type == OP_RV2CV)
8980 	o->op_private &= ~1;
8981 
8982     if (kid->op_type == OP_CONST) {
8983 	int iscv;
8984 	GV *gv;
8985 	SV * const kidsv = kid->op_sv;
8986 
8987 	/* Is it a constant from cv_const_sv()? */
8988 	if (SvROK(kidsv) && SvREADONLY(kidsv)) {
8989 	    SV * const rsv = SvRV(kidsv);
8990 	    const svtype type = SvTYPE(rsv);
8991             const char *badtype = NULL;
8992 
8993 	    switch (o->op_type) {
8994 	    case OP_RV2SV:
8995 		if (type > SVt_PVMG)
8996 		    badtype = "a SCALAR";
8997 		break;
8998 	    case OP_RV2AV:
8999 		if (type != SVt_PVAV)
9000 		    badtype = "an ARRAY";
9001 		break;
9002 	    case OP_RV2HV:
9003 		if (type != SVt_PVHV)
9004 		    badtype = "a HASH";
9005 		break;
9006 	    case OP_RV2CV:
9007 		if (type != SVt_PVCV)
9008 		    badtype = "a CODE";
9009 		break;
9010 	    }
9011 	    if (badtype)
9012 		Perl_croak(aTHX_ "Constant is not %s reference", badtype);
9013 	    return o;
9014 	}
9015 	if (SvTYPE(kidsv) == SVt_PVAV) return o;
9016 	if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
9017 	    const char *badthing;
9018 	    switch (o->op_type) {
9019 	    case OP_RV2SV:
9020 		badthing = "a SCALAR";
9021 		break;
9022 	    case OP_RV2AV:
9023 		badthing = "an ARRAY";
9024 		break;
9025 	    case OP_RV2HV:
9026 		badthing = "a HASH";
9027 		break;
9028 	    default:
9029 		badthing = NULL;
9030 		break;
9031 	    }
9032 	    if (badthing)
9033 		Perl_croak(aTHX_
9034 			   "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
9035 			   SVfARG(kidsv), badthing);
9036 	}
9037 	/*
9038 	 * This is a little tricky.  We only want to add the symbol if we
9039 	 * didn't add it in the lexer.  Otherwise we get duplicate strict
9040 	 * warnings.  But if we didn't add it in the lexer, we must at
9041 	 * least pretend like we wanted to add it even if it existed before,
9042 	 * or we get possible typo warnings.  OPpCONST_ENTERED says
9043 	 * whether the lexer already added THIS instance of this symbol.
9044 	 */
9045 	iscv = (o->op_type == OP_RV2CV) * 2;
9046 	do {
9047 	    gv = gv_fetchsv(kidsv,
9048 		iscv | !(kid->op_private & OPpCONST_ENTERED),
9049 		iscv
9050 		    ? SVt_PVCV
9051 		    : o->op_type == OP_RV2SV
9052 			? SVt_PV
9053 			: o->op_type == OP_RV2AV
9054 			    ? SVt_PVAV
9055 			    : o->op_type == OP_RV2HV
9056 				? SVt_PVHV
9057 				: SVt_PVGV);
9058 	} while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
9059 	if (gv) {
9060 	    kid->op_type = OP_GV;
9061 	    SvREFCNT_dec(kid->op_sv);
9062 #ifdef USE_ITHREADS
9063 	    /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
9064 	    assert (sizeof(PADOP) <= sizeof(SVOP));
9065 	    kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
9066 	    SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
9067 	    GvIN_PAD_on(gv);
9068 	    PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
9069 #else
9070 	    kid->op_sv = SvREFCNT_inc_simple_NN(gv);
9071 #endif
9072 	    kid->op_private = 0;
9073 	    kid->op_ppaddr = PL_ppaddr[OP_GV];
9074 	    /* FAKE globs in the symbol table cause weird bugs (#77810) */
9075 	    SvFAKE_off(gv);
9076 	}
9077     }
9078     return o;
9079 }
9080 
9081 OP *
9082 Perl_ck_ftst(pTHX_ OP *o)
9083 {
9084     dVAR;
9085     const I32 type = o->op_type;
9086 
9087     PERL_ARGS_ASSERT_CK_FTST;
9088 
9089     if (o->op_flags & OPf_REF) {
9090 	NOOP;
9091     }
9092     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
9093 	SVOP * const kid = (SVOP*)cUNOPo->op_first;
9094 	const OPCODE kidtype = kid->op_type;
9095 
9096 	if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
9097 	 && !kid->op_folded) {
9098 	    OP * const newop = newGVOP(type, OPf_REF,
9099 		gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
9100 #ifdef PERL_MAD
9101 	    op_getmad(o,newop,'O');
9102 #else
9103 	    op_free(o);
9104 #endif
9105 	    return newop;
9106 	}
9107 	if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
9108 	    o->op_private |= OPpFT_ACCESS;
9109 	if (PL_check[kidtype] == Perl_ck_ftst
9110 	        && kidtype != OP_STAT && kidtype != OP_LSTAT) {
9111 	    o->op_private |= OPpFT_STACKED;
9112 	    kid->op_private |= OPpFT_STACKING;
9113 	    if (kidtype == OP_FTTTY && (
9114 		   !(kid->op_private & OPpFT_STACKED)
9115 		|| kid->op_private & OPpFT_AFTER_t
9116 	       ))
9117 		o->op_private |= OPpFT_AFTER_t;
9118 	}
9119     }
9120     else {
9121 #ifdef PERL_MAD
9122 	OP* const oldo = o;
9123 #else
9124 	op_free(o);
9125 #endif
9126 	if (type == OP_FTTTY)
9127 	    o = newGVOP(type, OPf_REF, PL_stdingv);
9128 	else
9129 	    o = newUNOP(type, 0, newDEFSVOP());
9130 	op_getmad(oldo,o,'O');
9131     }
9132     return o;
9133 }
9134 
9135 OP *
9136 Perl_ck_fun(pTHX_ OP *o)
9137 {
9138     dVAR;
9139     const int type = o->op_type;
9140     I32 oa = PL_opargs[type] >> OASHIFT;
9141 
9142     PERL_ARGS_ASSERT_CK_FUN;
9143 
9144     if (o->op_flags & OPf_STACKED) {
9145 	if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
9146 	    oa &= ~OA_OPTIONAL;
9147 	else
9148 	    return no_fh_allowed(o);
9149     }
9150 
9151     if (o->op_flags & OPf_KIDS) {
9152         OP **tokid = &cLISTOPo->op_first;
9153         OP *kid = cLISTOPo->op_first;
9154         OP *sibl;
9155         I32 numargs = 0;
9156 	bool seen_optional = FALSE;
9157 
9158 	if (kid->op_type == OP_PUSHMARK ||
9159 	    (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
9160 	{
9161 	    tokid = &kid->op_sibling;
9162 	    kid = kid->op_sibling;
9163 	}
9164 	if (kid && kid->op_type == OP_COREARGS) {
9165 	    bool optional = FALSE;
9166 	    while (oa) {
9167 		numargs++;
9168 		if (oa & OA_OPTIONAL) optional = TRUE;
9169 		oa = oa >> 4;
9170 	    }
9171 	    if (optional) o->op_private |= numargs;
9172 	    return o;
9173 	}
9174 
9175 	while (oa) {
9176 	    if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
9177 		if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
9178 		    *tokid = kid = newDEFSVOP();
9179 		seen_optional = TRUE;
9180 	    }
9181 	    if (!kid) break;
9182 
9183 	    numargs++;
9184 	    sibl = kid->op_sibling;
9185 #ifdef PERL_MAD
9186 	    if (!sibl && kid->op_type == OP_STUB) {
9187 		numargs--;
9188 		break;
9189 	    }
9190 #endif
9191 	    switch (oa & 7) {
9192 	    case OA_SCALAR:
9193 		/* list seen where single (scalar) arg expected? */
9194 		if (numargs == 1 && !(oa >> 4)
9195 		    && kid->op_type == OP_LIST && type != OP_SCALAR)
9196 		{
9197 		    return too_many_arguments_pv(o,PL_op_desc[type], 0);
9198 		}
9199 		if (type != OP_DELETE) scalar(kid);
9200 		break;
9201 	    case OA_LIST:
9202 		if (oa < 16) {
9203 		    kid = 0;
9204 		    continue;
9205 		}
9206 		else
9207 		    list(kid);
9208 		break;
9209 	    case OA_AVREF:
9210 		if ((type == OP_PUSH || type == OP_UNSHIFT)
9211 		    && !kid->op_sibling)
9212 		    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
9213 				   "Useless use of %s with no values",
9214 				   PL_op_desc[type]);
9215 
9216 		if (kid->op_type == OP_CONST &&
9217 		    (kid->op_private & OPpCONST_BARE))
9218 		{
9219 		    OP * const newop = newAVREF(newGVOP(OP_GV, 0,
9220 			gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
9221 		    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9222 				   "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
9223 				   SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
9224 #ifdef PERL_MAD
9225 		    op_getmad(kid,newop,'K');
9226 #else
9227 		    op_free(kid);
9228 #endif
9229 		    kid = newop;
9230 		    kid->op_sibling = sibl;
9231 		    *tokid = kid;
9232 		}
9233 		else if (kid->op_type == OP_CONST
9234 		      && (  !SvROK(cSVOPx_sv(kid))
9235 		         || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
9236 		        )
9237 		    bad_type_pv(numargs, "array", PL_op_desc[type], 0, kid);
9238 		/* Defer checks to run-time if we have a scalar arg */
9239 		if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
9240 		    op_lvalue(kid, type);
9241 		else {
9242 		    scalar(kid);
9243 		    /* diag_listed_as: push on reference is experimental */
9244 		    Perl_ck_warner_d(aTHX_
9245 				     packWARN(WARN_EXPERIMENTAL__AUTODEREF),
9246 				    "%s on reference is experimental",
9247 				     PL_op_desc[type]);
9248 		}
9249 		break;
9250 	    case OA_HVREF:
9251 		if (kid->op_type == OP_CONST &&
9252 		    (kid->op_private & OPpCONST_BARE))
9253 		{
9254 		    OP * const newop = newHVREF(newGVOP(OP_GV, 0,
9255 			gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
9256 		    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9257 				   "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
9258 				   SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
9259 #ifdef PERL_MAD
9260 		    op_getmad(kid,newop,'K');
9261 #else
9262 		    op_free(kid);
9263 #endif
9264 		    kid = newop;
9265 		    kid->op_sibling = sibl;
9266 		    *tokid = kid;
9267 		}
9268 		else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
9269 		    bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid);
9270 		op_lvalue(kid, type);
9271 		break;
9272 	    case OA_CVREF:
9273 		{
9274 		    OP * const newop = newUNOP(OP_NULL, 0, kid);
9275 		    kid->op_sibling = 0;
9276 		    newop->op_next = newop;
9277 		    kid = newop;
9278 		    kid->op_sibling = sibl;
9279 		    *tokid = kid;
9280 		}
9281 		break;
9282 	    case OA_FILEREF:
9283 		if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
9284 		    if (kid->op_type == OP_CONST &&
9285 			(kid->op_private & OPpCONST_BARE))
9286 		    {
9287 			OP * const newop = newGVOP(OP_GV, 0,
9288 			    gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
9289 			if (!(o->op_private & 1) && /* if not unop */
9290 			    kid == cLISTOPo->op_last)
9291 			    cLISTOPo->op_last = newop;
9292 #ifdef PERL_MAD
9293 			op_getmad(kid,newop,'K');
9294 #else
9295 			op_free(kid);
9296 #endif
9297 			kid = newop;
9298 		    }
9299 		    else if (kid->op_type == OP_READLINE) {
9300 			/* neophyte patrol: open(<FH>), close(<FH>) etc. */
9301 			bad_type_pv(numargs, "HANDLE", OP_DESC(o), 0, kid);
9302 		    }
9303 		    else {
9304 			I32 flags = OPf_SPECIAL;
9305 			I32 priv = 0;
9306 			PADOFFSET targ = 0;
9307 
9308 			/* is this op a FH constructor? */
9309 			if (is_handle_constructor(o,numargs)) {
9310                             const char *name = NULL;
9311 			    STRLEN len = 0;
9312                             U32 name_utf8 = 0;
9313 			    bool want_dollar = TRUE;
9314 
9315 			    flags = 0;
9316 			    /* Set a flag to tell rv2gv to vivify
9317 			     * need to "prove" flag does not mean something
9318 			     * else already - NI-S 1999/05/07
9319 			     */
9320 			    priv = OPpDEREF;
9321 			    if (kid->op_type == OP_PADSV) {
9322 				SV *const namesv
9323 				    = PAD_COMPNAME_SV(kid->op_targ);
9324 				name = SvPV_const(namesv, len);
9325                                 name_utf8 = SvUTF8(namesv);
9326 			    }
9327 			    else if (kid->op_type == OP_RV2SV
9328 				     && kUNOP->op_first->op_type == OP_GV)
9329 			    {
9330 				GV * const gv = cGVOPx_gv(kUNOP->op_first);
9331 				name = GvNAME(gv);
9332 				len = GvNAMELEN(gv);
9333                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
9334 			    }
9335 			    else if (kid->op_type == OP_AELEM
9336 				     || kid->op_type == OP_HELEM)
9337 			    {
9338 				 OP *firstop;
9339 				 OP *op = ((BINOP*)kid)->op_first;
9340 				 name = NULL;
9341 				 if (op) {
9342 				      SV *tmpstr = NULL;
9343 				      const char * const a =
9344 					   kid->op_type == OP_AELEM ?
9345 					   "[]" : "{}";
9346 				      if (((op->op_type == OP_RV2AV) ||
9347 					   (op->op_type == OP_RV2HV)) &&
9348 					  (firstop = ((UNOP*)op)->op_first) &&
9349 					  (firstop->op_type == OP_GV)) {
9350 					   /* packagevar $a[] or $h{} */
9351 					   GV * const gv = cGVOPx_gv(firstop);
9352 					   if (gv)
9353 						tmpstr =
9354 						     Perl_newSVpvf(aTHX_
9355 								   "%s%c...%c",
9356 								   GvNAME(gv),
9357 								   a[0], a[1]);
9358 				      }
9359 				      else if (op->op_type == OP_PADAV
9360 					       || op->op_type == OP_PADHV) {
9361 					   /* lexicalvar $a[] or $h{} */
9362 					   const char * const padname =
9363 						PAD_COMPNAME_PV(op->op_targ);
9364 					   if (padname)
9365 						tmpstr =
9366 						     Perl_newSVpvf(aTHX_
9367 								   "%s%c...%c",
9368 								   padname + 1,
9369 								   a[0], a[1]);
9370 				      }
9371 				      if (tmpstr) {
9372 					   name = SvPV_const(tmpstr, len);
9373                                            name_utf8 = SvUTF8(tmpstr);
9374 					   sv_2mortal(tmpstr);
9375 				      }
9376 				 }
9377 				 if (!name) {
9378 				      name = "__ANONIO__";
9379 				      len = 10;
9380 				      want_dollar = FALSE;
9381 				 }
9382 				 op_lvalue(kid, type);
9383 			    }
9384 			    if (name) {
9385 				SV *namesv;
9386 				targ = pad_alloc(OP_RV2GV, SVf_READONLY);
9387 				namesv = PAD_SVl(targ);
9388 				if (want_dollar && *name != '$')
9389 				    sv_setpvs(namesv, "$");
9390 				else
9391 				    sv_setpvs(namesv, "");
9392 				sv_catpvn(namesv, name, len);
9393                                 if ( name_utf8 ) SvUTF8_on(namesv);
9394 			    }
9395 			}
9396 			kid->op_sibling = 0;
9397 			kid = newUNOP(OP_RV2GV, flags, scalar(kid));
9398 			kid->op_targ = targ;
9399 			kid->op_private |= priv;
9400 		    }
9401 		    kid->op_sibling = sibl;
9402 		    *tokid = kid;
9403 		}
9404 		scalar(kid);
9405 		break;
9406 	    case OA_SCALARREF:
9407 		if ((type == OP_UNDEF || type == OP_POS)
9408 		    && numargs == 1 && !(oa >> 4)
9409 		    && kid->op_type == OP_LIST)
9410 		    return too_many_arguments_pv(o,PL_op_desc[type], 0);
9411 		op_lvalue(scalar(kid), type);
9412 		break;
9413 	    }
9414 	    oa >>= 4;
9415 	    tokid = &kid->op_sibling;
9416 	    kid = kid->op_sibling;
9417 	}
9418 #ifdef PERL_MAD
9419 	if (kid && kid->op_type != OP_STUB)
9420 	    return too_many_arguments_pv(o,OP_DESC(o), 0);
9421 	o->op_private |= numargs;
9422 #else
9423 	/* FIXME - should the numargs move as for the PERL_MAD case?  */
9424 	o->op_private |= numargs;
9425 	if (kid)
9426 	    return too_many_arguments_pv(o,OP_DESC(o), 0);
9427 #endif
9428 	listkids(o);
9429     }
9430     else if (PL_opargs[type] & OA_DEFGV) {
9431 #ifdef PERL_MAD
9432 	OP *newop = newUNOP(type, 0, newDEFSVOP());
9433 	op_getmad(o,newop,'O');
9434 	return newop;
9435 #else
9436 	/* Ordering of these two is important to keep f_map.t passing.  */
9437 	op_free(o);
9438 	return newUNOP(type, 0, newDEFSVOP());
9439 #endif
9440     }
9441 
9442     if (oa) {
9443 	while (oa & OA_OPTIONAL)
9444 	    oa >>= 4;
9445 	if (oa && oa != OA_LIST)
9446 	    return too_few_arguments_pv(o,OP_DESC(o), 0);
9447     }
9448     return o;
9449 }
9450 
9451 OP *
9452 Perl_ck_glob(pTHX_ OP *o)
9453 {
9454     dVAR;
9455     GV *gv;
9456 
9457     PERL_ARGS_ASSERT_CK_GLOB;
9458 
9459     o = ck_fun(o);
9460     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
9461 	op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
9462 
9463     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
9464     {
9465 	/* convert
9466 	 *     glob
9467 	 *       \ null - const(wildcard)
9468 	 * into
9469 	 *     null
9470 	 *       \ enter
9471 	 *            \ list
9472 	 *                 \ mark - glob - rv2cv
9473 	 *                             |        \ gv(CORE::GLOBAL::glob)
9474 	 *                             |
9475 	 *                              \ null - const(wildcard)
9476 	 */
9477 	o->op_flags |= OPf_SPECIAL;
9478 	o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
9479 	o = S_new_entersubop(aTHX_ gv, o);
9480 	o = newUNOP(OP_NULL, 0, o);
9481 	o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
9482 	return o;
9483     }
9484     else o->op_flags &= ~OPf_SPECIAL;
9485 #if !defined(PERL_EXTERNAL_GLOB)
9486     if (!PL_globhook) {
9487 	ENTER;
9488 	Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
9489 			       newSVpvs("File::Glob"), NULL, NULL, NULL);
9490 	LEAVE;
9491     }
9492 #endif /* !PERL_EXTERNAL_GLOB */
9493     gv = (GV *)newSV(0);
9494     gv_init(gv, 0, "", 0, 0);
9495     gv_IOadd(gv);
9496     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
9497     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
9498     scalarkids(o);
9499     return o;
9500 }
9501 
9502 OP *
9503 Perl_ck_grep(pTHX_ OP *o)
9504 {
9505     dVAR;
9506     LOGOP *gwop;
9507     OP *kid;
9508     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
9509     PADOFFSET offset;
9510 
9511     PERL_ARGS_ASSERT_CK_GREP;
9512 
9513     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
9514     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
9515 
9516     if (o->op_flags & OPf_STACKED) {
9517         kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
9518 	if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
9519 	    return no_fh_allowed(o);
9520 	o->op_flags &= ~OPf_STACKED;
9521     }
9522     kid = cLISTOPo->op_first->op_sibling;
9523     if (type == OP_MAPWHILE)
9524 	list(kid);
9525     else
9526 	scalar(kid);
9527     o = ck_fun(o);
9528     if (PL_parser && PL_parser->error_count)
9529 	return o;
9530     kid = cLISTOPo->op_first->op_sibling;
9531     if (kid->op_type != OP_NULL)
9532 	Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
9533     kid = kUNOP->op_first;
9534 
9535     NewOp(1101, gwop, 1, LOGOP);
9536     gwop->op_type = type;
9537     gwop->op_ppaddr = PL_ppaddr[type];
9538     gwop->op_first = o;
9539     gwop->op_flags |= OPf_KIDS;
9540     gwop->op_other = LINKLIST(kid);
9541     kid->op_next = (OP*)gwop;
9542     offset = pad_findmy_pvs("$_", 0);
9543     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
9544 	o->op_private = gwop->op_private = 0;
9545 	gwop->op_targ = pad_alloc(type, SVs_PADTMP);
9546     }
9547     else {
9548 	o->op_private = gwop->op_private = OPpGREP_LEX;
9549 	gwop->op_targ = o->op_targ = offset;
9550     }
9551 
9552     kid = cLISTOPo->op_first->op_sibling;
9553     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
9554 	op_lvalue(kid, OP_GREPSTART);
9555 
9556     return (OP*)gwop;
9557 }
9558 
9559 OP *
9560 Perl_ck_index(pTHX_ OP *o)
9561 {
9562     PERL_ARGS_ASSERT_CK_INDEX;
9563 
9564     if (o->op_flags & OPf_KIDS) {
9565 	OP *kid = cLISTOPo->op_first->op_sibling;	/* get past pushmark */
9566 	if (kid)
9567 	    kid = kid->op_sibling;			/* get past "big" */
9568 	if (kid && kid->op_type == OP_CONST) {
9569 	    const bool save_taint = TAINT_get;
9570 	    SV *sv = kSVOP->op_sv;
9571 	    if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
9572 		sv = newSV(0);
9573 		sv_copypv(sv, kSVOP->op_sv);
9574 		SvREFCNT_dec_NN(kSVOP->op_sv);
9575 		kSVOP->op_sv = sv;
9576 	    }
9577 	    if (SvOK(sv)) fbm_compile(sv, 0);
9578 	    TAINT_set(save_taint);
9579 #ifdef NO_TAINT_SUPPORT
9580             PERL_UNUSED_VAR(save_taint);
9581 #endif
9582 	}
9583     }
9584     return ck_fun(o);
9585 }
9586 
9587 OP *
9588 Perl_ck_lfun(pTHX_ OP *o)
9589 {
9590     const OPCODE type = o->op_type;
9591 
9592     PERL_ARGS_ASSERT_CK_LFUN;
9593 
9594     return modkids(ck_fun(o), type);
9595 }
9596 
9597 OP *
9598 Perl_ck_defined(pTHX_ OP *o)		/* 19990527 MJD */
9599 {
9600     PERL_ARGS_ASSERT_CK_DEFINED;
9601 
9602     if ((o->op_flags & OPf_KIDS)) {
9603 	switch (cUNOPo->op_first->op_type) {
9604 	case OP_RV2AV:
9605 	case OP_PADAV:
9606 	case OP_AASSIGN:		/* Is this a good idea? */
9607 	    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9608 			   "defined(@array) is deprecated");
9609 	    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9610 			   "\t(Maybe you should just omit the defined()?)\n");
9611 	break;
9612 	case OP_RV2HV:
9613 	case OP_PADHV:
9614 	    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9615 			   "defined(%%hash) is deprecated");
9616 	    Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
9617 			   "\t(Maybe you should just omit the defined()?)\n");
9618 	    break;
9619 	default:
9620 	    /* no warning */
9621 	    break;
9622 	}
9623     }
9624     return ck_rfun(o);
9625 }
9626 
9627 OP *
9628 Perl_ck_readline(pTHX_ OP *o)
9629 {
9630     PERL_ARGS_ASSERT_CK_READLINE;
9631 
9632     if (o->op_flags & OPf_KIDS) {
9633 	 OP *kid = cLISTOPo->op_first;
9634 	 if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
9635     }
9636     else {
9637 	OP * const newop
9638 	    = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
9639 #ifdef PERL_MAD
9640 	op_getmad(o,newop,'O');
9641 #else
9642 	op_free(o);
9643 #endif
9644 	return newop;
9645     }
9646     return o;
9647 }
9648 
9649 OP *
9650 Perl_ck_rfun(pTHX_ OP *o)
9651 {
9652     const OPCODE type = o->op_type;
9653 
9654     PERL_ARGS_ASSERT_CK_RFUN;
9655 
9656     return refkids(ck_fun(o), type);
9657 }
9658 
9659 OP *
9660 Perl_ck_listiob(pTHX_ OP *o)
9661 {
9662     OP *kid;
9663 
9664     PERL_ARGS_ASSERT_CK_LISTIOB;
9665 
9666     kid = cLISTOPo->op_first;
9667     if (!kid) {
9668 	o = force_list(o);
9669 	kid = cLISTOPo->op_first;
9670     }
9671     if (kid->op_type == OP_PUSHMARK)
9672 	kid = kid->op_sibling;
9673     if (kid && o->op_flags & OPf_STACKED)
9674 	kid = kid->op_sibling;
9675     else if (kid && !kid->op_sibling) {		/* print HANDLE; */
9676 	if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
9677 	 && !kid->op_folded) {
9678 	    o->op_flags |= OPf_STACKED;	/* make it a filehandle */
9679 	    kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
9680 	    cLISTOPo->op_first->op_sibling = kid;
9681 	    cLISTOPo->op_last = kid;
9682 	    kid = kid->op_sibling;
9683 	}
9684     }
9685 
9686     if (!kid)
9687 	op_append_elem(o->op_type, o, newDEFSVOP());
9688 
9689     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
9690     return listkids(o);
9691 }
9692 
9693 OP *
9694 Perl_ck_smartmatch(pTHX_ OP *o)
9695 {
9696     dVAR;
9697     PERL_ARGS_ASSERT_CK_SMARTMATCH;
9698     if (0 == (o->op_flags & OPf_SPECIAL)) {
9699 	OP *first  = cBINOPo->op_first;
9700 	OP *second = first->op_sibling;
9701 
9702 	/* Implicitly take a reference to an array or hash */
9703 	first->op_sibling = NULL;
9704 	first = cBINOPo->op_first = ref_array_or_hash(first);
9705 	second = first->op_sibling = ref_array_or_hash(second);
9706 
9707 	/* Implicitly take a reference to a regular expression */
9708 	if (first->op_type == OP_MATCH) {
9709 	    first->op_type = OP_QR;
9710 	    first->op_ppaddr = PL_ppaddr[OP_QR];
9711 	}
9712 	if (second->op_type == OP_MATCH) {
9713 	    second->op_type = OP_QR;
9714 	    second->op_ppaddr = PL_ppaddr[OP_QR];
9715         }
9716     }
9717 
9718     return o;
9719 }
9720 
9721 
9722 OP *
9723 Perl_ck_sassign(pTHX_ OP *o)
9724 {
9725     dVAR;
9726     OP * const kid = cLISTOPo->op_first;
9727 
9728     PERL_ARGS_ASSERT_CK_SASSIGN;
9729 
9730     /* has a disposable target? */
9731     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
9732 	&& !(kid->op_flags & OPf_STACKED)
9733 	/* Cannot steal the second time! */
9734 	&& !(kid->op_private & OPpTARGET_MY)
9735 	/* Keep the full thing for madskills */
9736 	&& !PL_madskills
9737 	)
9738     {
9739 	OP * const kkid = kid->op_sibling;
9740 
9741 	/* Can just relocate the target. */
9742 	if (kkid && kkid->op_type == OP_PADSV
9743 	    && !(kkid->op_private & OPpLVAL_INTRO))
9744 	{
9745 	    kid->op_targ = kkid->op_targ;
9746 	    kkid->op_targ = 0;
9747 	    /* Now we do not need PADSV and SASSIGN. */
9748 	    kid->op_sibling = o->op_sibling;	/* NULL */
9749 	    cLISTOPo->op_first = NULL;
9750 	    op_free(o);
9751 	    op_free(kkid);
9752 	    kid->op_private |= OPpTARGET_MY;	/* Used for context settings */
9753 	    return kid;
9754 	}
9755     }
9756     if (kid->op_sibling) {
9757 	OP *kkid = kid->op_sibling;
9758 	/* For state variable assignment, kkid is a list op whose op_last
9759 	   is a padsv. */
9760 	if ((kkid->op_type == OP_PADSV ||
9761 	     (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
9762 	      (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
9763 	     )
9764 	    )
9765 		&& (kkid->op_private & OPpLVAL_INTRO)
9766 		&& SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
9767 	    const PADOFFSET target = kkid->op_targ;
9768 	    OP *const other = newOP(OP_PADSV,
9769 				    kkid->op_flags
9770 				    | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
9771 	    OP *const first = newOP(OP_NULL, 0);
9772 	    OP *const nullop = newCONDOP(0, first, o, other);
9773 	    OP *const condop = first->op_next;
9774 	    /* hijacking PADSTALE for uninitialized state variables */
9775 	    SvPADSTALE_on(PAD_SVl(target));
9776 
9777 	    condop->op_type = OP_ONCE;
9778 	    condop->op_ppaddr = PL_ppaddr[OP_ONCE];
9779 	    condop->op_targ = target;
9780 	    other->op_targ = target;
9781 
9782 	    /* Because we change the type of the op here, we will skip the
9783 	       assignment binop->op_last = binop->op_first->op_sibling; at the
9784 	       end of Perl_newBINOP(). So need to do it here. */
9785 	    cBINOPo->op_last = cBINOPo->op_first->op_sibling;
9786 
9787 	    return nullop;
9788 	}
9789     }
9790     return o;
9791 }
9792 
9793 OP *
9794 Perl_ck_match(pTHX_ OP *o)
9795 {
9796     dVAR;
9797 
9798     PERL_ARGS_ASSERT_CK_MATCH;
9799 
9800     if (o->op_type != OP_QR && PL_compcv) {
9801 	const PADOFFSET offset = pad_findmy_pvs("$_", 0);
9802 	if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
9803 	    o->op_targ = offset;
9804 	    o->op_private |= OPpTARGET_MY;
9805 	}
9806     }
9807     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
9808 	o->op_private |= OPpRUNTIME;
9809     return o;
9810 }
9811 
9812 OP *
9813 Perl_ck_method(pTHX_ OP *o)
9814 {
9815     OP * const kid = cUNOPo->op_first;
9816 
9817     PERL_ARGS_ASSERT_CK_METHOD;
9818 
9819     if (kid->op_type == OP_CONST) {
9820 	SV* sv = kSVOP->op_sv;
9821 	const char * const method = SvPVX_const(sv);
9822 	if (!(strchr(method, ':') || strchr(method, '\''))) {
9823 	    OP *cmop;
9824 	    if (!SvIsCOW_shared_hash(sv)) {
9825 		sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
9826 	    }
9827 	    else {
9828 		kSVOP->op_sv = NULL;
9829 	    }
9830 	    cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
9831 #ifdef PERL_MAD
9832 	    op_getmad(o,cmop,'O');
9833 #else
9834 	    op_free(o);
9835 #endif
9836 	    return cmop;
9837 	}
9838     }
9839     return o;
9840 }
9841 
9842 OP *
9843 Perl_ck_null(pTHX_ OP *o)
9844 {
9845     PERL_ARGS_ASSERT_CK_NULL;
9846     PERL_UNUSED_CONTEXT;
9847     return o;
9848 }
9849 
9850 OP *
9851 Perl_ck_open(pTHX_ OP *o)
9852 {
9853     dVAR;
9854 
9855     PERL_ARGS_ASSERT_CK_OPEN;
9856 
9857     S_io_hints(aTHX_ o);
9858     {
9859 	 /* In case of three-arg dup open remove strictness
9860 	  * from the last arg if it is a bareword. */
9861 	 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
9862 	 OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
9863 	 OP *oa;
9864 	 const char *mode;
9865 
9866 	 if ((last->op_type == OP_CONST) &&		/* The bareword. */
9867 	     (last->op_private & OPpCONST_BARE) &&
9868 	     (last->op_private & OPpCONST_STRICT) &&
9869 	     (oa = first->op_sibling) &&		/* The fh. */
9870 	     (oa = oa->op_sibling) &&			/* The mode. */
9871 	     (oa->op_type == OP_CONST) &&
9872 	     SvPOK(((SVOP*)oa)->op_sv) &&
9873 	     (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
9874 	     mode[0] == '>' && mode[1] == '&' &&	/* A dup open. */
9875 	     (last == oa->op_sibling))			/* The bareword. */
9876 	      last->op_private &= ~OPpCONST_STRICT;
9877     }
9878     return ck_fun(o);
9879 }
9880 
9881 OP *
9882 Perl_ck_repeat(pTHX_ OP *o)
9883 {
9884     PERL_ARGS_ASSERT_CK_REPEAT;
9885 
9886     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
9887 	o->op_private |= OPpREPEAT_DOLIST;
9888 	cBINOPo->op_first = force_list(cBINOPo->op_first);
9889     }
9890     else
9891 	scalar(o);
9892     return o;
9893 }
9894 
9895 OP *
9896 Perl_ck_require(pTHX_ OP *o)
9897 {
9898     dVAR;
9899     GV* gv;
9900 
9901     PERL_ARGS_ASSERT_CK_REQUIRE;
9902 
9903     if (o->op_flags & OPf_KIDS) {	/* Shall we supply missing .pm? */
9904 	SVOP * const kid = (SVOP*)cUNOPo->op_first;
9905 
9906 	if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
9907 	    SV * const sv = kid->op_sv;
9908 	    U32 was_readonly = SvREADONLY(sv);
9909 	    char *s;
9910 	    STRLEN len;
9911 	    const char *end;
9912 
9913 	    if (was_readonly) {
9914 		    SvREADONLY_off(sv);
9915 	    }
9916 	    if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
9917 
9918 	    s = SvPVX(sv);
9919 	    len = SvCUR(sv);
9920 	    end = s + len;
9921 	    for (; s < end; s++) {
9922 		if (*s == ':' && s[1] == ':') {
9923 		    *s = '/';
9924 		    Move(s+2, s+1, end - s - 1, char);
9925 		    --end;
9926 		}
9927 	    }
9928 	    SvEND_set(sv, end);
9929 	    sv_catpvs(sv, ".pm");
9930 	    SvFLAGS(sv) |= was_readonly;
9931 	}
9932     }
9933 
9934     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
9935 	/* handle override, if any */
9936      && (gv = gv_override("require", 7))) {
9937 	OP *kid, *newop;
9938 	if (o->op_flags & OPf_KIDS) {
9939 	    kid = cUNOPo->op_first;
9940 	    cUNOPo->op_first = NULL;
9941 	}
9942 	else {
9943 	    kid = newDEFSVOP();
9944 	}
9945 #ifndef PERL_MAD
9946 	op_free(o);
9947 #endif
9948 	newop = S_new_entersubop(aTHX_ gv, kid);
9949 	op_getmad(o,newop,'O');
9950 	return newop;
9951     }
9952 
9953     return scalar(ck_fun(o));
9954 }
9955 
9956 OP *
9957 Perl_ck_return(pTHX_ OP *o)
9958 {
9959     dVAR;
9960     OP *kid;
9961 
9962     PERL_ARGS_ASSERT_CK_RETURN;
9963 
9964     kid = cLISTOPo->op_first->op_sibling;
9965     if (CvLVALUE(PL_compcv)) {
9966 	for (; kid; kid = kid->op_sibling)
9967 	    op_lvalue(kid, OP_LEAVESUBLV);
9968     }
9969 
9970     return o;
9971 }
9972 
9973 OP *
9974 Perl_ck_select(pTHX_ OP *o)
9975 {
9976     dVAR;
9977     OP* kid;
9978 
9979     PERL_ARGS_ASSERT_CK_SELECT;
9980 
9981     if (o->op_flags & OPf_KIDS) {
9982 	kid = cLISTOPo->op_first->op_sibling;	/* get past pushmark */
9983 	if (kid && kid->op_sibling) {
9984 	    o->op_type = OP_SSELECT;
9985 	    o->op_ppaddr = PL_ppaddr[OP_SSELECT];
9986 	    o = ck_fun(o);
9987 	    return fold_constants(op_integerize(op_std_init(o)));
9988 	}
9989     }
9990     o = ck_fun(o);
9991     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
9992     if (kid && kid->op_type == OP_RV2GV)
9993 	kid->op_private &= ~HINT_STRICT_REFS;
9994     return o;
9995 }
9996 
9997 OP *
9998 Perl_ck_shift(pTHX_ OP *o)
9999 {
10000     dVAR;
10001     const I32 type = o->op_type;
10002 
10003     PERL_ARGS_ASSERT_CK_SHIFT;
10004 
10005     if (!(o->op_flags & OPf_KIDS)) {
10006 	OP *argop;
10007 
10008 	if (!CvUNIQUE(PL_compcv)) {
10009 	    o->op_flags |= OPf_SPECIAL;
10010 	    return o;
10011 	}
10012 
10013 	argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
10014 #ifdef PERL_MAD
10015 	{
10016 	    OP * const oldo = o;
10017 	    o = newUNOP(type, 0, scalar(argop));
10018 	    op_getmad(oldo,o,'O');
10019 	    return o;
10020 	}
10021 #else
10022 	op_free(o);
10023 	return newUNOP(type, 0, scalar(argop));
10024 #endif
10025     }
10026     return scalar(ck_fun(o));
10027 }
10028 
10029 OP *
10030 Perl_ck_sort(pTHX_ OP *o)
10031 {
10032     dVAR;
10033     OP *firstkid;
10034     OP *kid;
10035     HV * const hinthv =
10036 	PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
10037     U8 stacked;
10038 
10039     PERL_ARGS_ASSERT_CK_SORT;
10040 
10041     if (hinthv) {
10042 	    SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
10043 	    if (svp) {
10044 		const I32 sorthints = (I32)SvIV(*svp);
10045 		if ((sorthints & HINT_SORT_QUICKSORT) != 0)
10046 		    o->op_private |= OPpSORT_QSORT;
10047 		if ((sorthints & HINT_SORT_STABLE) != 0)
10048 		    o->op_private |= OPpSORT_STABLE;
10049 	    }
10050     }
10051 
10052     if (o->op_flags & OPf_STACKED)
10053 	simplify_sort(o);
10054     firstkid = cLISTOPo->op_first->op_sibling;		/* get past pushmark */
10055 
10056     if ((stacked = o->op_flags & OPf_STACKED)) {	/* may have been cleared */
10057 	OP *kid = cUNOPx(firstkid)->op_first;		/* get past null */
10058 
10059         /* if the first arg is a code block, process it and mark sort as
10060          * OPf_SPECIAL */
10061 	if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
10062 	    LINKLIST(kid);
10063 	    if (kid->op_type == OP_LEAVE)
10064 		    op_null(kid);			/* wipe out leave */
10065 	    /* Prevent execution from escaping out of the sort block. */
10066 	    kid->op_next = 0;
10067 
10068 	    /* provide scalar context for comparison function/block */
10069 	    kid = scalar(firstkid);
10070 	    kid->op_next = kid;
10071 	    o->op_flags |= OPf_SPECIAL;
10072 	}
10073 
10074 	firstkid = firstkid->op_sibling;
10075     }
10076 
10077     for (kid = firstkid; kid; kid = kid->op_sibling) {
10078 	/* provide list context for arguments */
10079 	list(kid);
10080 	if (stacked)
10081 	    op_lvalue(kid, OP_GREPSTART);
10082     }
10083 
10084     return o;
10085 }
10086 
10087 /* for sort { X } ..., where X is one of
10088  *   $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a
10089  * elide the second child of the sort (the one containing X),
10090  * and set these flags as appropriate
10091 	OPpSORT_NUMERIC;
10092 	OPpSORT_INTEGER;
10093 	OPpSORT_DESCEND;
10094  * Also, check and warn on lexical $a, $b.
10095  */
10096 
10097 STATIC void
10098 S_simplify_sort(pTHX_ OP *o)
10099 {
10100     dVAR;
10101     OP *kid = cLISTOPo->op_first->op_sibling;	/* get past pushmark */
10102     OP *k;
10103     int descending;
10104     GV *gv;
10105     const char *gvname;
10106     bool have_scopeop;
10107 
10108     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
10109 
10110     kid = kUNOP->op_first;				/* get past null */
10111     if (!(have_scopeop = kid->op_type == OP_SCOPE)
10112      && kid->op_type != OP_LEAVE)
10113 	return;
10114     kid = kLISTOP->op_last;				/* get past scope */
10115     switch(kid->op_type) {
10116 	case OP_NCMP:
10117 	case OP_I_NCMP:
10118 	case OP_SCMP:
10119 	    if (!have_scopeop) goto padkids;
10120 	    break;
10121 	default:
10122 	    return;
10123     }
10124     k = kid;						/* remember this node*/
10125     if (kBINOP->op_first->op_type != OP_RV2SV
10126      || kBINOP->op_last ->op_type != OP_RV2SV)
10127     {
10128 	/*
10129 	   Warn about my($a) or my($b) in a sort block, *if* $a or $b is
10130 	   then used in a comparison.  This catches most, but not
10131 	   all cases.  For instance, it catches
10132 	       sort { my($a); $a <=> $b }
10133 	   but not
10134 	       sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
10135 	   (although why you'd do that is anyone's guess).
10136 	*/
10137 
10138        padkids:
10139 	if (!ckWARN(WARN_SYNTAX)) return;
10140 	kid = kBINOP->op_first;
10141 	do {
10142 	    if (kid->op_type == OP_PADSV) {
10143 		SV * const name = AvARRAY(PL_comppad_name)[kid->op_targ];
10144 		if (SvCUR(name) == 2 && *SvPVX(name) == '$'
10145 		 && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
10146 		    /* diag_listed_as: "my %s" used in sort comparison */
10147 		    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10148 				     "\"%s %s\" used in sort comparison",
10149 				      SvPAD_STATE(name) ? "state" : "my",
10150 				      SvPVX(name));
10151 	    }
10152 	} while ((kid = kid->op_sibling));
10153 	return;
10154     }
10155     kid = kBINOP->op_first;				/* get past cmp */
10156     if (kUNOP->op_first->op_type != OP_GV)
10157 	return;
10158     kid = kUNOP->op_first;				/* get past rv2sv */
10159     gv = kGVOP_gv;
10160     if (GvSTASH(gv) != PL_curstash)
10161 	return;
10162     gvname = GvNAME(gv);
10163     if (*gvname == 'a' && gvname[1] == '\0')
10164 	descending = 0;
10165     else if (*gvname == 'b' && gvname[1] == '\0')
10166 	descending = 1;
10167     else
10168 	return;
10169 
10170     kid = k;						/* back to cmp */
10171     /* already checked above that it is rv2sv */
10172     kid = kBINOP->op_last;				/* down to 2nd arg */
10173     if (kUNOP->op_first->op_type != OP_GV)
10174 	return;
10175     kid = kUNOP->op_first;				/* get past rv2sv */
10176     gv = kGVOP_gv;
10177     if (GvSTASH(gv) != PL_curstash)
10178 	return;
10179     gvname = GvNAME(gv);
10180     if ( descending
10181 	 ? !(*gvname == 'a' && gvname[1] == '\0')
10182 	 : !(*gvname == 'b' && gvname[1] == '\0'))
10183 	return;
10184     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
10185     if (descending)
10186 	o->op_private |= OPpSORT_DESCEND;
10187     if (k->op_type == OP_NCMP)
10188 	o->op_private |= OPpSORT_NUMERIC;
10189     if (k->op_type == OP_I_NCMP)
10190 	o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
10191     kid = cLISTOPo->op_first->op_sibling;
10192     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
10193 #ifdef PERL_MAD
10194     op_getmad(kid,o,'S');			      /* then delete it */
10195 #else
10196     op_free(kid);				      /* then delete it */
10197 #endif
10198 }
10199 
10200 OP *
10201 Perl_ck_split(pTHX_ OP *o)
10202 {
10203     dVAR;
10204     OP *kid;
10205 
10206     PERL_ARGS_ASSERT_CK_SPLIT;
10207 
10208     if (o->op_flags & OPf_STACKED)
10209 	return no_fh_allowed(o);
10210 
10211     kid = cLISTOPo->op_first;
10212     if (kid->op_type != OP_NULL)
10213 	Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
10214     kid = kid->op_sibling;
10215     op_free(cLISTOPo->op_first);
10216     if (kid)
10217 	cLISTOPo->op_first = kid;
10218     else {
10219 	cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
10220 	cLISTOPo->op_last = kid; /* There was only one element previously */
10221     }
10222 
10223     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
10224 	OP * const sibl = kid->op_sibling;
10225 	kid->op_sibling = 0;
10226         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
10227 	if (cLISTOPo->op_first == cLISTOPo->op_last)
10228 	    cLISTOPo->op_last = kid;
10229 	cLISTOPo->op_first = kid;
10230 	kid->op_sibling = sibl;
10231     }
10232 
10233     kid->op_type = OP_PUSHRE;
10234     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
10235     scalar(kid);
10236     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
10237       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10238 		     "Use of /g modifier is meaningless in split");
10239     }
10240 
10241     if (!kid->op_sibling)
10242 	op_append_elem(OP_SPLIT, o, newDEFSVOP());
10243 
10244     kid = kid->op_sibling;
10245     scalar(kid);
10246 
10247     if (!kid->op_sibling)
10248     {
10249 	op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
10250 	o->op_private |= OPpSPLIT_IMPLIM;
10251     }
10252     assert(kid->op_sibling);
10253 
10254     kid = kid->op_sibling;
10255     scalar(kid);
10256 
10257     if (kid->op_sibling)
10258 	return too_many_arguments_pv(o,OP_DESC(o), 0);
10259 
10260     return o;
10261 }
10262 
10263 OP *
10264 Perl_ck_join(pTHX_ OP *o)
10265 {
10266     const OP * const kid = cLISTOPo->op_first->op_sibling;
10267 
10268     PERL_ARGS_ASSERT_CK_JOIN;
10269 
10270     if (kid && kid->op_type == OP_MATCH) {
10271 	if (ckWARN(WARN_SYNTAX)) {
10272             const REGEXP *re = PM_GETRE(kPMOP);
10273             const SV *msg = re
10274                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
10275                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
10276                     : newSVpvs_flags( "STRING", SVs_TEMP );
10277 	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10278 			"/%"SVf"/ should probably be written as \"%"SVf"\"",
10279 			SVfARG(msg), SVfARG(msg));
10280 	}
10281     }
10282     return ck_fun(o);
10283 }
10284 
10285 /*
10286 =for apidoc Am|CV *|rv2cv_op_cv|OP *cvop|U32 flags
10287 
10288 Examines an op, which is expected to identify a subroutine at runtime,
10289 and attempts to determine at compile time which subroutine it identifies.
10290 This is normally used during Perl compilation to determine whether
10291 a prototype can be applied to a function call.  I<cvop> is the op
10292 being considered, normally an C<rv2cv> op.  A pointer to the identified
10293 subroutine is returned, if it could be determined statically, and a null
10294 pointer is returned if it was not possible to determine statically.
10295 
10296 Currently, the subroutine can be identified statically if the RV that the
10297 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
10298 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
10299 suitable if the constant value must be an RV pointing to a CV.  Details of
10300 this process may change in future versions of Perl.  If the C<rv2cv> op
10301 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
10302 the subroutine statically: this flag is used to suppress compile-time
10303 magic on a subroutine call, forcing it to use default runtime behaviour.
10304 
10305 If I<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
10306 of a GV reference is modified.  If a GV was examined and its CV slot was
10307 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
10308 If the op is not optimised away, and the CV slot is later populated with
10309 a subroutine having a prototype, that flag eventually triggers the warning
10310 "called too early to check prototype".
10311 
10312 If I<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
10313 of returning a pointer to the subroutine it returns a pointer to the
10314 GV giving the most appropriate name for the subroutine in this context.
10315 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
10316 (C<CvANON>) subroutine that is referenced through a GV it will be the
10317 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
10318 A null pointer is returned as usual if there is no statically-determinable
10319 subroutine.
10320 
10321 =cut
10322 */
10323 
10324 /* shared by toke.c:yylex */
10325 CV *
10326 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
10327 {
10328     PADNAME *name = PAD_COMPNAME(off);
10329     CV *compcv = PL_compcv;
10330     while (PadnameOUTER(name)) {
10331 	assert(PARENT_PAD_INDEX(name));
10332 	compcv = CvOUTSIDE(PL_compcv);
10333 	name = PadlistNAMESARRAY(CvPADLIST(compcv))
10334 		[off = PARENT_PAD_INDEX(name)];
10335     }
10336     assert(!PadnameIsOUR(name));
10337     if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
10338 	MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
10339 	assert(mg);
10340 	assert(mg->mg_obj);
10341 	return (CV *)mg->mg_obj;
10342     }
10343     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
10344 }
10345 
10346 CV *
10347 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
10348 {
10349     OP *rvop;
10350     CV *cv;
10351     GV *gv;
10352     PERL_ARGS_ASSERT_RV2CV_OP_CV;
10353     if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
10354 	Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
10355     if (cvop->op_type != OP_RV2CV)
10356 	return NULL;
10357     if (cvop->op_private & OPpENTERSUB_AMPER)
10358 	return NULL;
10359     if (!(cvop->op_flags & OPf_KIDS))
10360 	return NULL;
10361     rvop = cUNOPx(cvop)->op_first;
10362     switch (rvop->op_type) {
10363 	case OP_GV: {
10364 	    gv = cGVOPx_gv(rvop);
10365 	    cv = GvCVu(gv);
10366 	    if (!cv) {
10367 		if (flags & RV2CVOPCV_MARK_EARLY)
10368 		    rvop->op_private |= OPpEARLY_CV;
10369 		return NULL;
10370 	    }
10371 	} break;
10372 	case OP_CONST: {
10373 	    SV *rv = cSVOPx_sv(rvop);
10374 	    if (!SvROK(rv))
10375 		return NULL;
10376 	    cv = (CV*)SvRV(rv);
10377 	    gv = NULL;
10378 	} break;
10379 	case OP_PADCV: {
10380 	    cv = find_lexical_cv(rvop->op_targ);
10381 	    gv = NULL;
10382 	} break;
10383 	default: {
10384 	    return NULL;
10385 	} break;
10386     }
10387     if (SvTYPE((SV*)cv) != SVt_PVCV)
10388 	return NULL;
10389     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
10390 	if (!CvANON(cv) || !gv)
10391 	    gv = CvGV(cv);
10392 	return (CV*)gv;
10393     } else {
10394 	return cv;
10395     }
10396 }
10397 
10398 /*
10399 =for apidoc Am|OP *|ck_entersub_args_list|OP *entersubop
10400 
10401 Performs the default fixup of the arguments part of an C<entersub>
10402 op tree.  This consists of applying list context to each of the
10403 argument ops.  This is the standard treatment used on a call marked
10404 with C<&>, or a method call, or a call through a subroutine reference,
10405 or any other call where the callee can't be identified at compile time,
10406 or a call where the callee has no prototype.
10407 
10408 =cut
10409 */
10410 
10411 OP *
10412 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
10413 {
10414     OP *aop;
10415     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
10416     aop = cUNOPx(entersubop)->op_first;
10417     if (!aop->op_sibling)
10418 	aop = cUNOPx(aop)->op_first;
10419     for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
10420 	if (!(PL_madskills && aop->op_type == OP_STUB)) {
10421 	    list(aop);
10422 	    op_lvalue(aop, OP_ENTERSUB);
10423 	}
10424     }
10425     return entersubop;
10426 }
10427 
10428 /*
10429 =for apidoc Am|OP *|ck_entersub_args_proto|OP *entersubop|GV *namegv|SV *protosv
10430 
10431 Performs the fixup of the arguments part of an C<entersub> op tree
10432 based on a subroutine prototype.  This makes various modifications to
10433 the argument ops, from applying context up to inserting C<refgen> ops,
10434 and checking the number and syntactic types of arguments, as directed by
10435 the prototype.  This is the standard treatment used on a subroutine call,
10436 not marked with C<&>, where the callee can be identified at compile time
10437 and has a prototype.
10438 
10439 I<protosv> supplies the subroutine prototype to be applied to the call.
10440 It may be a normal defined scalar, of which the string value will be used.
10441 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10442 that has been cast to C<SV*>) which has a prototype.  The prototype
10443 supplied, in whichever form, does not need to match the actual callee
10444 referenced by the op tree.
10445 
10446 If the argument ops disagree with the prototype, for example by having
10447 an unacceptable number of arguments, a valid op tree is returned anyway.
10448 The error is reflected in the parser state, normally resulting in a single
10449 exception at the top level of parsing which covers all the compilation
10450 errors that occurred.  In the error message, the callee is referred to
10451 by the name defined by the I<namegv> parameter.
10452 
10453 =cut
10454 */
10455 
10456 OP *
10457 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10458 {
10459     STRLEN proto_len;
10460     const char *proto, *proto_end;
10461     OP *aop, *prev, *cvop;
10462     int optional = 0;
10463     I32 arg = 0;
10464     I32 contextclass = 0;
10465     const char *e = NULL;
10466     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
10467     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
10468 	Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
10469 		   "flags=%lx", (unsigned long) SvFLAGS(protosv));
10470     if (SvTYPE(protosv) == SVt_PVCV)
10471 	 proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
10472     else proto = SvPV(protosv, proto_len);
10473     proto = S_strip_spaces(aTHX_ proto, &proto_len);
10474     proto_end = proto + proto_len;
10475     aop = cUNOPx(entersubop)->op_first;
10476     if (!aop->op_sibling)
10477 	aop = cUNOPx(aop)->op_first;
10478     prev = aop;
10479     aop = aop->op_sibling;
10480     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10481     while (aop != cvop) {
10482 	OP* o3;
10483 	if (PL_madskills && aop->op_type == OP_STUB) {
10484 	    aop = aop->op_sibling;
10485 	    continue;
10486 	}
10487 	if (PL_madskills && aop->op_type == OP_NULL)
10488 	    o3 = ((UNOP*)aop)->op_first;
10489 	else
10490 	    o3 = aop;
10491 
10492 	if (proto >= proto_end)
10493 	    return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
10494 
10495 	switch (*proto) {
10496 	    case ';':
10497 		optional = 1;
10498 		proto++;
10499 		continue;
10500 	    case '_':
10501 		/* _ must be at the end */
10502 		if (proto[1] && !strchr(";@%", proto[1]))
10503 		    goto oops;
10504 	    case '$':
10505 		proto++;
10506 		arg++;
10507 		scalar(aop);
10508 		break;
10509 	    case '%':
10510 	    case '@':
10511 		list(aop);
10512 		arg++;
10513 		break;
10514 	    case '&':
10515 		proto++;
10516 		arg++;
10517 		if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
10518 		    bad_type_gv(arg,
10519 			    arg == 1 ? "block or sub {}" : "sub {}",
10520 			    namegv, 0, o3);
10521 		break;
10522 	    case '*':
10523 		/* '*' allows any scalar type, including bareword */
10524 		proto++;
10525 		arg++;
10526 		if (o3->op_type == OP_RV2GV)
10527 		    goto wrapref;	/* autoconvert GLOB -> GLOBref */
10528 		else if (o3->op_type == OP_CONST)
10529 		    o3->op_private &= ~OPpCONST_STRICT;
10530 		else if (o3->op_type == OP_ENTERSUB) {
10531 		    /* accidental subroutine, revert to bareword */
10532 		    OP *gvop = ((UNOP*)o3)->op_first;
10533 		    if (gvop && gvop->op_type == OP_NULL) {
10534 			gvop = ((UNOP*)gvop)->op_first;
10535 			if (gvop) {
10536 			    for (; gvop->op_sibling; gvop = gvop->op_sibling)
10537 				;
10538 			    if (gvop &&
10539 				    (gvop->op_private & OPpENTERSUB_NOPAREN) &&
10540 				    (gvop = ((UNOP*)gvop)->op_first) &&
10541 				    gvop->op_type == OP_GV)
10542 			    {
10543 				GV * const gv = cGVOPx_gv(gvop);
10544 				OP * const sibling = aop->op_sibling;
10545 				SV * const n = newSVpvs("");
10546 #ifdef PERL_MAD
10547 				OP * const oldaop = aop;
10548 #else
10549 				op_free(aop);
10550 #endif
10551 				gv_fullname4(n, gv, "", FALSE);
10552 				aop = newSVOP(OP_CONST, 0, n);
10553 				op_getmad(oldaop,aop,'O');
10554 				prev->op_sibling = aop;
10555 				aop->op_sibling = sibling;
10556 			    }
10557 			}
10558 		    }
10559 		}
10560 		scalar(aop);
10561 		break;
10562 	    case '+':
10563 		proto++;
10564 		arg++;
10565 		if (o3->op_type == OP_RV2AV ||
10566 		    o3->op_type == OP_PADAV ||
10567 		    o3->op_type == OP_RV2HV ||
10568 		    o3->op_type == OP_PADHV
10569 		) {
10570 		    goto wrapref;
10571 		}
10572 		scalar(aop);
10573 		break;
10574 	    case '[': case ']':
10575 		goto oops;
10576 		break;
10577 	    case '\\':
10578 		proto++;
10579 		arg++;
10580 	    again:
10581 		switch (*proto++) {
10582 		    case '[':
10583 			if (contextclass++ == 0) {
10584 			    e = strchr(proto, ']');
10585 			    if (!e || e == proto)
10586 				goto oops;
10587 			}
10588 			else
10589 			    goto oops;
10590 			goto again;
10591 			break;
10592 		    case ']':
10593 			if (contextclass) {
10594 			    const char *p = proto;
10595 			    const char *const end = proto;
10596 			    contextclass = 0;
10597 			    while (*--p != '[')
10598 				/* \[$] accepts any scalar lvalue */
10599 				if (*p == '$'
10600 				 && Perl_op_lvalue_flags(aTHX_
10601 				     scalar(o3),
10602 				     OP_READ, /* not entersub */
10603 				     OP_LVALUE_NO_CROAK
10604 				    )) goto wrapref;
10605 			    bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
10606 					(int)(end - p), p),
10607 				    namegv, 0, o3);
10608 			} else
10609 			    goto oops;
10610 			break;
10611 		    case '*':
10612 			if (o3->op_type == OP_RV2GV)
10613 			    goto wrapref;
10614 			if (!contextclass)
10615 			    bad_type_gv(arg, "symbol", namegv, 0, o3);
10616 			break;
10617 		    case '&':
10618 			if (o3->op_type == OP_ENTERSUB)
10619 			    goto wrapref;
10620 			if (!contextclass)
10621 			    bad_type_gv(arg, "subroutine entry", namegv, 0,
10622 				    o3);
10623 			break;
10624 		    case '$':
10625 			if (o3->op_type == OP_RV2SV ||
10626 				o3->op_type == OP_PADSV ||
10627 				o3->op_type == OP_HELEM ||
10628 				o3->op_type == OP_AELEM)
10629 			    goto wrapref;
10630 			if (!contextclass) {
10631 			    /* \$ accepts any scalar lvalue */
10632 			    if (Perl_op_lvalue_flags(aTHX_
10633 				    scalar(o3),
10634 				    OP_READ,  /* not entersub */
10635 				    OP_LVALUE_NO_CROAK
10636 			       )) goto wrapref;
10637 			    bad_type_gv(arg, "scalar", namegv, 0, o3);
10638 			}
10639 			break;
10640 		    case '@':
10641 			if (o3->op_type == OP_RV2AV ||
10642 				o3->op_type == OP_PADAV)
10643 			    goto wrapref;
10644 			if (!contextclass)
10645 			    bad_type_gv(arg, "array", namegv, 0, o3);
10646 			break;
10647 		    case '%':
10648 			if (o3->op_type == OP_RV2HV ||
10649 				o3->op_type == OP_PADHV)
10650 			    goto wrapref;
10651 			if (!contextclass)
10652 			    bad_type_gv(arg, "hash", namegv, 0, o3);
10653 			break;
10654 		    wrapref:
10655 			{
10656 			    OP* const kid = aop;
10657 			    OP* const sib = kid->op_sibling;
10658 			    kid->op_sibling = 0;
10659 			    aop = newUNOP(OP_REFGEN, 0, kid);
10660 			    aop->op_sibling = sib;
10661 			    prev->op_sibling = aop;
10662 			}
10663 			if (contextclass && e) {
10664 			    proto = e + 1;
10665 			    contextclass = 0;
10666 			}
10667 			break;
10668 		    default: goto oops;
10669 		}
10670 		if (contextclass)
10671 		    goto again;
10672 		break;
10673 	    case ' ':
10674 		proto++;
10675 		continue;
10676 	    default:
10677 	    oops: {
10678                 SV* const tmpsv = sv_newmortal();
10679                 gv_efullname3(tmpsv, namegv, NULL);
10680 		Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
10681 			SVfARG(tmpsv), SVfARG(protosv));
10682             }
10683 	}
10684 
10685 	op_lvalue(aop, OP_ENTERSUB);
10686 	prev = aop;
10687 	aop = aop->op_sibling;
10688     }
10689     if (aop == cvop && *proto == '_') {
10690 	/* generate an access to $_ */
10691 	aop = newDEFSVOP();
10692 	aop->op_sibling = prev->op_sibling;
10693 	prev->op_sibling = aop; /* instead of cvop */
10694     }
10695     if (!optional && proto_end > proto &&
10696 	(*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
10697 	return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
10698     return entersubop;
10699 }
10700 
10701 /*
10702 =for apidoc Am|OP *|ck_entersub_args_proto_or_list|OP *entersubop|GV *namegv|SV *protosv
10703 
10704 Performs the fixup of the arguments part of an C<entersub> op tree either
10705 based on a subroutine prototype or using default list-context processing.
10706 This is the standard treatment used on a subroutine call, not marked
10707 with C<&>, where the callee can be identified at compile time.
10708 
10709 I<protosv> supplies the subroutine prototype to be applied to the call,
10710 or indicates that there is no prototype.  It may be a normal scalar,
10711 in which case if it is defined then the string value will be used
10712 as a prototype, and if it is undefined then there is no prototype.
10713 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
10714 that has been cast to C<SV*>), of which the prototype will be used if it
10715 has one.  The prototype (or lack thereof) supplied, in whichever form,
10716 does not need to match the actual callee referenced by the op tree.
10717 
10718 If the argument ops disagree with the prototype, for example by having
10719 an unacceptable number of arguments, a valid op tree is returned anyway.
10720 The error is reflected in the parser state, normally resulting in a single
10721 exception at the top level of parsing which covers all the compilation
10722 errors that occurred.  In the error message, the callee is referred to
10723 by the name defined by the I<namegv> parameter.
10724 
10725 =cut
10726 */
10727 
10728 OP *
10729 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
10730 	GV *namegv, SV *protosv)
10731 {
10732     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
10733     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
10734 	return ck_entersub_args_proto(entersubop, namegv, protosv);
10735     else
10736 	return ck_entersub_args_list(entersubop);
10737 }
10738 
10739 OP *
10740 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
10741 {
10742     int opnum = SvTYPE(protosv) == SVt_PVCV ? 0 : (int)SvUV(protosv);
10743     OP *aop = cUNOPx(entersubop)->op_first;
10744 
10745     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
10746 
10747     if (!opnum) {
10748 	OP *cvop;
10749 	if (!aop->op_sibling)
10750 	    aop = cUNOPx(aop)->op_first;
10751 	aop = aop->op_sibling;
10752 	for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10753 	if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) {
10754 	    aop = aop->op_sibling;
10755 	}
10756 	if (aop != cvop)
10757 	    (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0);
10758 
10759 	op_free(entersubop);
10760 	switch(GvNAME(namegv)[2]) {
10761 	case 'F': return newSVOP(OP_CONST, 0,
10762 					newSVpv(CopFILE(PL_curcop),0));
10763 	case 'L': return newSVOP(
10764 	                   OP_CONST, 0,
10765                            Perl_newSVpvf(aTHX_
10766 	                     "%"IVdf, (IV)CopLINE(PL_curcop)
10767 	                   )
10768 	                 );
10769 	case 'P': return newSVOP(OP_CONST, 0,
10770 	                           (PL_curstash
10771 	                             ? newSVhek(HvNAME_HEK(PL_curstash))
10772 	                             : &PL_sv_undef
10773 	                           )
10774 	                        );
10775 	}
10776 	NOT_REACHED;
10777     }
10778     else {
10779 	OP *prev, *cvop;
10780 	U32 flags;
10781 #ifdef PERL_MAD
10782 	bool seenarg = FALSE;
10783 #endif
10784 	if (!aop->op_sibling)
10785 	    aop = cUNOPx(aop)->op_first;
10786 
10787 	prev = aop;
10788 	aop = aop->op_sibling;
10789 	prev->op_sibling = NULL;
10790 	for (cvop = aop;
10791 	     cvop->op_sibling;
10792 	     prev=cvop, cvop = cvop->op_sibling)
10793 #ifdef PERL_MAD
10794 	    if (PL_madskills && cvop->op_sibling
10795 	     && cvop->op_type != OP_STUB) seenarg = TRUE
10796 #endif
10797 	    ;
10798 	prev->op_sibling = NULL;
10799 	flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN);
10800 	op_free(cvop);
10801 	if (aop == cvop) aop = NULL;
10802 	op_free(entersubop);
10803 
10804 	if (opnum == OP_ENTEREVAL
10805 	 && GvNAMELEN(namegv)==9 && strnEQ(GvNAME(namegv), "evalbytes", 9))
10806 	    flags |= OPpEVAL_BYTES <<8;
10807 
10808 	switch (PL_opargs[opnum] & OA_CLASS_MASK) {
10809 	case OA_UNOP:
10810 	case OA_BASEOP_OR_UNOP:
10811 	case OA_FILESTATOP:
10812 	    return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags);
10813 	case OA_BASEOP:
10814 	    if (aop) {
10815 #ifdef PERL_MAD
10816 		if (!PL_madskills || seenarg)
10817 #endif
10818 		    (void)too_many_arguments_pv(aop, GvNAME(namegv), 0);
10819 		op_free(aop);
10820 	    }
10821 	    return opnum == OP_RUNCV
10822 		? newPVOP(OP_RUNCV,0,NULL)
10823 		: newOP(opnum,0);
10824 	default:
10825 	    return convert(opnum,0,aop);
10826 	}
10827     }
10828     assert(0);
10829     return entersubop;
10830 }
10831 
10832 /*
10833 =for apidoc Am|void|cv_get_call_checker|CV *cv|Perl_call_checker *ckfun_p|SV **ckobj_p
10834 
10835 Retrieves the function that will be used to fix up a call to I<cv>.
10836 Specifically, the function is applied to an C<entersub> op tree for a
10837 subroutine call, not marked with C<&>, where the callee can be identified
10838 at compile time as I<cv>.
10839 
10840 The C-level function pointer is returned in I<*ckfun_p>, and an SV
10841 argument for it is returned in I<*ckobj_p>.  The function is intended
10842 to be called in this manner:
10843 
10844     entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
10845 
10846 In this call, I<entersubop> is a pointer to the C<entersub> op,
10847 which may be replaced by the check function, and I<namegv> is a GV
10848 supplying the name that should be used by the check function to refer
10849 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10850 It is permitted to apply the check function in non-standard situations,
10851 such as to a call to a different subroutine or to a method call.
10852 
10853 By default, the function is
10854 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
10855 and the SV parameter is I<cv> itself.  This implements standard
10856 prototype processing.  It can be changed, for a particular subroutine,
10857 by L</cv_set_call_checker>.
10858 
10859 =cut
10860 */
10861 
10862 void
10863 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
10864 {
10865     MAGIC *callmg;
10866     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
10867     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
10868     if (callmg) {
10869 	*ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
10870 	*ckobj_p = callmg->mg_obj;
10871     } else {
10872 	*ckfun_p = Perl_ck_entersub_args_proto_or_list;
10873 	*ckobj_p = (SV*)cv;
10874     }
10875 }
10876 
10877 /*
10878 =for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj
10879 
10880 Sets the function that will be used to fix up a call to I<cv>.
10881 Specifically, the function is applied to an C<entersub> op tree for a
10882 subroutine call, not marked with C<&>, where the callee can be identified
10883 at compile time as I<cv>.
10884 
10885 The C-level function pointer is supplied in I<ckfun>, and an SV argument
10886 for it is supplied in I<ckobj>.  The function should be defined like this:
10887 
10888     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
10889 
10890 It is intended to be called in this manner:
10891 
10892     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
10893 
10894 In this call, I<entersubop> is a pointer to the C<entersub> op,
10895 which may be replaced by the check function, and I<namegv> is a GV
10896 supplying the name that should be used by the check function to refer
10897 to the callee of the C<entersub> op if it needs to emit any diagnostics.
10898 It is permitted to apply the check function in non-standard situations,
10899 such as to a call to a different subroutine or to a method call.
10900 
10901 The current setting for a particular CV can be retrieved by
10902 L</cv_get_call_checker>.
10903 
10904 =cut
10905 */
10906 
10907 void
10908 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
10909 {
10910     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
10911     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
10912 	if (SvMAGICAL((SV*)cv))
10913 	    mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
10914     } else {
10915 	MAGIC *callmg;
10916 	sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
10917 	callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
10918 	if (callmg->mg_flags & MGf_REFCOUNTED) {
10919 	    SvREFCNT_dec(callmg->mg_obj);
10920 	    callmg->mg_flags &= ~MGf_REFCOUNTED;
10921 	}
10922 	callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
10923 	callmg->mg_obj = ckobj;
10924 	if (ckobj != (SV*)cv) {
10925 	    SvREFCNT_inc_simple_void_NN(ckobj);
10926 	    callmg->mg_flags |= MGf_REFCOUNTED;
10927 	}
10928 	callmg->mg_flags |= MGf_COPY;
10929     }
10930 }
10931 
10932 OP *
10933 Perl_ck_subr(pTHX_ OP *o)
10934 {
10935     OP *aop, *cvop;
10936     CV *cv;
10937     GV *namegv;
10938 
10939     PERL_ARGS_ASSERT_CK_SUBR;
10940 
10941     aop = cUNOPx(o)->op_first;
10942     if (!aop->op_sibling)
10943 	aop = cUNOPx(aop)->op_first;
10944     aop = aop->op_sibling;
10945     for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
10946     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
10947     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
10948 
10949     o->op_private &= ~1;
10950     o->op_private |= OPpENTERSUB_HASTARG;
10951     o->op_private |= (PL_hints & HINT_STRICT_REFS);
10952     if (PERLDB_SUB && PL_curstash != PL_debstash)
10953 	o->op_private |= OPpENTERSUB_DB;
10954     if (cvop->op_type == OP_RV2CV) {
10955 	o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
10956 	op_null(cvop);
10957     } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
10958 	if (aop->op_type == OP_CONST)
10959 	    aop->op_private &= ~OPpCONST_STRICT;
10960 	else if (aop->op_type == OP_LIST) {
10961 	    OP * const sib = ((UNOP*)aop)->op_first->op_sibling;
10962 	    if (sib && sib->op_type == OP_CONST)
10963 		sib->op_private &= ~OPpCONST_STRICT;
10964 	}
10965     }
10966 
10967     if (!cv) {
10968 	return ck_entersub_args_list(o);
10969     } else {
10970 	Perl_call_checker ckfun;
10971 	SV *ckobj;
10972 	cv_get_call_checker(cv, &ckfun, &ckobj);
10973 	if (!namegv) { /* expletive! */
10974 	    /* XXX The call checker API is public.  And it guarantees that
10975 		   a GV will be provided with the right name.  So we have
10976 		   to create a GV.  But it is still not correct, as its
10977 		   stringification will include the package.  What we
10978 		   really need is a new call checker API that accepts a
10979 		   GV or string (or GV or CV). */
10980 	    HEK * const hek = CvNAME_HEK(cv);
10981 	    /* After a syntax error in a lexical sub, the cv that
10982 	       rv2cv_op_cv returns may be a nameless stub. */
10983 	    if (!hek) return ck_entersub_args_list(o);;
10984 	    namegv = (GV *)sv_newmortal();
10985 	    gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
10986 			SVf_UTF8 * !!HEK_UTF8(hek));
10987 	}
10988 	return ckfun(aTHX_ o, namegv, ckobj);
10989     }
10990 }
10991 
10992 OP *
10993 Perl_ck_svconst(pTHX_ OP *o)
10994 {
10995     SV * const sv = cSVOPo->op_sv;
10996     PERL_ARGS_ASSERT_CK_SVCONST;
10997     PERL_UNUSED_CONTEXT;
10998 #ifdef PERL_OLD_COPY_ON_WRITE
10999     if (SvIsCOW(sv)) sv_force_normal(sv);
11000 #elif defined(PERL_NEW_COPY_ON_WRITE)
11001     /* Since the read-only flag may be used to protect a string buffer, we
11002        cannot do copy-on-write with existing read-only scalars that are not
11003        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
11004        that constant, mark the constant as COWable here, if it is not
11005        already read-only. */
11006     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
11007 	SvIsCOW_on(sv);
11008 	CowREFCNT(sv) = 0;
11009 # ifdef PERL_DEBUG_READONLY_COW
11010 	sv_buf_to_ro(sv);
11011 # endif
11012     }
11013 #endif
11014     SvREADONLY_on(sv);
11015     return o;
11016 }
11017 
11018 OP *
11019 Perl_ck_trunc(pTHX_ OP *o)
11020 {
11021     PERL_ARGS_ASSERT_CK_TRUNC;
11022 
11023     if (o->op_flags & OPf_KIDS) {
11024 	SVOP *kid = (SVOP*)cUNOPo->op_first;
11025 
11026 	if (kid->op_type == OP_NULL)
11027 	    kid = (SVOP*)kid->op_sibling;
11028 	if (kid && kid->op_type == OP_CONST &&
11029 	    (kid->op_private & OPpCONST_BARE) &&
11030 	    !kid->op_folded)
11031 	{
11032 	    o->op_flags |= OPf_SPECIAL;
11033 	    kid->op_private &= ~OPpCONST_STRICT;
11034 	}
11035     }
11036     return ck_fun(o);
11037 }
11038 
11039 OP *
11040 Perl_ck_substr(pTHX_ OP *o)
11041 {
11042     PERL_ARGS_ASSERT_CK_SUBSTR;
11043 
11044     o = ck_fun(o);
11045     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
11046 	OP *kid = cLISTOPo->op_first;
11047 
11048 	if (kid->op_type == OP_NULL)
11049 	    kid = kid->op_sibling;
11050 	if (kid)
11051 	    kid->op_flags |= OPf_MOD;
11052 
11053     }
11054     return o;
11055 }
11056 
11057 OP *
11058 Perl_ck_tell(pTHX_ OP *o)
11059 {
11060     PERL_ARGS_ASSERT_CK_TELL;
11061     o = ck_fun(o);
11062     if (o->op_flags & OPf_KIDS) {
11063      OP *kid = cLISTOPo->op_first;
11064      if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
11065      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
11066     }
11067     return o;
11068 }
11069 
11070 OP *
11071 Perl_ck_each(pTHX_ OP *o)
11072 {
11073     dVAR;
11074     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
11075     const unsigned orig_type  = o->op_type;
11076     const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
11077 	                      : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
11078     const unsigned ref_type   = orig_type == OP_EACH ? OP_REACH
11079 	                      : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
11080 
11081     PERL_ARGS_ASSERT_CK_EACH;
11082 
11083     if (kid) {
11084 	switch (kid->op_type) {
11085 	    case OP_PADHV:
11086 	    case OP_RV2HV:
11087 		break;
11088 	    case OP_PADAV:
11089 	    case OP_RV2AV:
11090 		CHANGE_TYPE(o, array_type);
11091 		break;
11092 	    case OP_CONST:
11093 		if (kid->op_private == OPpCONST_BARE
11094 		 || !SvROK(cSVOPx_sv(kid))
11095 		 || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
11096 		    && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
11097 		   )
11098 		    /* we let ck_fun handle it */
11099 		    break;
11100 	    default:
11101 		CHANGE_TYPE(o, ref_type);
11102 		scalar(kid);
11103 	}
11104     }
11105     /* if treating as a reference, defer additional checks to runtime */
11106     if (o->op_type == ref_type) {
11107 	/* diag_listed_as: keys on reference is experimental */
11108 	Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF),
11109 			      "%s is experimental", PL_op_desc[ref_type]);
11110 	return o;
11111     }
11112     return ck_fun(o);
11113 }
11114 
11115 OP *
11116 Perl_ck_length(pTHX_ OP *o)
11117 {
11118     PERL_ARGS_ASSERT_CK_LENGTH;
11119 
11120     o = ck_fun(o);
11121 
11122     if (ckWARN(WARN_SYNTAX)) {
11123         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
11124 
11125         if (kid) {
11126             SV *name = NULL;
11127             const bool hash = kid->op_type == OP_PADHV
11128                            || kid->op_type == OP_RV2HV;
11129             switch (kid->op_type) {
11130                 case OP_PADHV:
11131                 case OP_PADAV:
11132                 case OP_RV2HV:
11133                 case OP_RV2AV:
11134 		    name = S_op_varname(aTHX_ kid);
11135                     break;
11136                 default:
11137                     return o;
11138             }
11139             if (name)
11140                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11141                     "length() used on %"SVf" (did you mean \"scalar(%s%"SVf
11142                     ")\"?)",
11143                     name, hash ? "keys " : "", name
11144                 );
11145             else if (hash)
11146      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11147                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11148                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
11149             else
11150      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
11151                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11152                     "length() used on @array (did you mean \"scalar(@array)\"?)");
11153         }
11154     }
11155 
11156     return o;
11157 }
11158 
11159 /* Check for in place reverse and sort assignments like "@a = reverse @a"
11160    and modify the optree to make them work inplace */
11161 
11162 STATIC void
11163 S_inplace_aassign(pTHX_ OP *o) {
11164 
11165     OP *modop, *modop_pushmark;
11166     OP *oright;
11167     OP *oleft, *oleft_pushmark;
11168 
11169     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
11170 
11171     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
11172 
11173     assert(cUNOPo->op_first->op_type == OP_NULL);
11174     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
11175     assert(modop_pushmark->op_type == OP_PUSHMARK);
11176     modop = modop_pushmark->op_sibling;
11177 
11178     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
11179 	return;
11180 
11181     /* no other operation except sort/reverse */
11182     if (modop->op_sibling)
11183 	return;
11184 
11185     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
11186     if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
11187 
11188     if (modop->op_flags & OPf_STACKED) {
11189 	/* skip sort subroutine/block */
11190 	assert(oright->op_type == OP_NULL);
11191 	oright = oright->op_sibling;
11192     }
11193 
11194     assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
11195     oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
11196     assert(oleft_pushmark->op_type == OP_PUSHMARK);
11197     oleft = oleft_pushmark->op_sibling;
11198 
11199     /* Check the lhs is an array */
11200     if (!oleft ||
11201 	(oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
11202 	|| oleft->op_sibling
11203 	|| (oleft->op_private & OPpLVAL_INTRO)
11204     )
11205 	return;
11206 
11207     /* Only one thing on the rhs */
11208     if (oright->op_sibling)
11209 	return;
11210 
11211     /* check the array is the same on both sides */
11212     if (oleft->op_type == OP_RV2AV) {
11213 	if (oright->op_type != OP_RV2AV
11214 	    || !cUNOPx(oright)->op_first
11215 	    || cUNOPx(oright)->op_first->op_type != OP_GV
11216 	    || cUNOPx(oleft )->op_first->op_type != OP_GV
11217 	    || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
11218 	       cGVOPx_gv(cUNOPx(oright)->op_first)
11219 	)
11220 	    return;
11221     }
11222     else if (oright->op_type != OP_PADAV
11223 	|| oright->op_targ != oleft->op_targ
11224     )
11225 	return;
11226 
11227     /* This actually is an inplace assignment */
11228 
11229     modop->op_private |= OPpSORT_INPLACE;
11230 
11231     /* transfer MODishness etc from LHS arg to RHS arg */
11232     oright->op_flags = oleft->op_flags;
11233 
11234     /* remove the aassign op and the lhs */
11235     op_null(o);
11236     op_null(oleft_pushmark);
11237     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
11238 	op_null(cUNOPx(oleft)->op_first);
11239     op_null(oleft);
11240 }
11241 
11242 
11243 
11244 /* mechanism for deferring recursion in rpeep() */
11245 
11246 #define MAX_DEFERRED 4
11247 
11248 #define DEFER(o) \
11249   STMT_START { \
11250     if (defer_ix == (MAX_DEFERRED-1)) { \
11251         OP **defer = defer_queue[defer_base]; \
11252         CALL_RPEEP(*defer); \
11253         S_prune_chain_head(aTHX_ defer); \
11254 	defer_base = (defer_base + 1) % MAX_DEFERRED; \
11255 	defer_ix--; \
11256     } \
11257     defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \
11258   } STMT_END
11259 
11260 #define IS_AND_OP(o)   (o->op_type == OP_AND)
11261 #define IS_OR_OP(o)    (o->op_type == OP_OR)
11262 
11263 
11264 STATIC void
11265 S_null_listop_in_list_context(pTHX_ OP *o)
11266 {
11267     PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
11268 
11269     /* This is an OP_LIST in list context. That means we
11270      * can ditch the OP_LIST and the OP_PUSHMARK within. */
11271 
11272     op_null(cUNOPo->op_first); /* NULL the pushmark */
11273     op_null(o); /* NULL the list */
11274 }
11275 
11276 /* A peephole optimizer.  We visit the ops in the order they're to execute.
11277  * See the comments at the top of this file for more details about when
11278  * peep() is called */
11279 
11280 void
11281 Perl_rpeep(pTHX_ OP *o)
11282 {
11283     dVAR;
11284     OP* oldop = NULL;
11285     OP* oldoldop = NULL;
11286     OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
11287     int defer_base = 0;
11288     int defer_ix = -1;
11289 
11290     if (!o || o->op_opt)
11291 	return;
11292     ENTER;
11293     SAVEOP();
11294     SAVEVPTR(PL_curcop);
11295     for (;; o = o->op_next) {
11296 	if (o && o->op_opt)
11297 	    o = NULL;
11298 	if (!o) {
11299 	    while (defer_ix >= 0) {
11300                 OP **defer =
11301                         defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED];
11302                 CALL_RPEEP(*defer);
11303                 S_prune_chain_head(aTHX_ defer);
11304             }
11305 	    break;
11306 	}
11307 
11308 	/* By default, this op has now been optimised. A couple of cases below
11309 	   clear this again.  */
11310 	o->op_opt = 1;
11311 	PL_op = o;
11312 
11313 
11314         /* The following will have the OP_LIST and OP_PUSHMARK
11315          * patched out later IF the OP_LIST is in list context.
11316          * So in that case, we can set the this OP's op_next
11317          * to skip to after the OP_PUSHMARK:
11318          *   a THIS -> b
11319          *   d list -> e
11320          *   b   pushmark -> c
11321          *   c   whatever -> d
11322          *   e whatever
11323          * will eventually become:
11324          *   a THIS -> c
11325          *   - ex-list -> -
11326          *   -   ex-pushmark -> -
11327          *   c   whatever -> e
11328          *   e whatever
11329          */
11330         {
11331             OP *sibling;
11332             OP *other_pushmark;
11333             if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
11334                 && (sibling = o->op_sibling)
11335                 && sibling->op_type == OP_LIST
11336                 /* This KIDS check is likely superfluous since OP_LIST
11337                  * would otherwise be an OP_STUB. */
11338                 && sibling->op_flags & OPf_KIDS
11339                 && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
11340                 && (other_pushmark = cLISTOPx(sibling)->op_first)
11341                 /* Pointer equality also effectively checks that it's a
11342                  * pushmark. */
11343                 && other_pushmark == o->op_next)
11344             {
11345                 o->op_next = other_pushmark->op_next;
11346                 null_listop_in_list_context(sibling);
11347             }
11348         }
11349 
11350 	switch (o->op_type) {
11351 	case OP_DBSTATE:
11352 	    PL_curcop = ((COP*)o);		/* for warnings */
11353 	    break;
11354 	case OP_NEXTSTATE:
11355 	    PL_curcop = ((COP*)o);		/* for warnings */
11356 
11357 	    /* Optimise a "return ..." at the end of a sub to just be "...".
11358 	     * This saves 2 ops. Before:
11359 	     * 1  <;> nextstate(main 1 -e:1) v ->2
11360 	     * 4  <@> return K ->5
11361 	     * 2    <0> pushmark s ->3
11362 	     * -    <1> ex-rv2sv sK/1 ->4
11363 	     * 3      <#> gvsv[*cat] s ->4
11364 	     *
11365 	     * After:
11366 	     * -  <@> return K ->-
11367 	     * -    <0> pushmark s ->2
11368 	     * -    <1> ex-rv2sv sK/1 ->-
11369 	     * 2      <$> gvsv(*cat) s ->3
11370 	     */
11371 	    {
11372 		OP *next = o->op_next;
11373 		OP *sibling = o->op_sibling;
11374 		if (   OP_TYPE_IS(next, OP_PUSHMARK)
11375 		    && OP_TYPE_IS(sibling, OP_RETURN)
11376 		    && OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
11377 		    && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
11378 		    && cUNOPx(sibling)->op_first == next
11379 		    && next->op_sibling && next->op_sibling->op_next
11380 		    && next->op_next
11381 		) {
11382 		    /* Look through the PUSHMARK's siblings for one that
11383 		     * points to the RETURN */
11384 		    OP *top = next->op_sibling;
11385 		    while (top && top->op_next) {
11386 			if (top->op_next == sibling) {
11387 			    top->op_next = sibling->op_next;
11388 			    o->op_next = next->op_next;
11389 			    break;
11390 			}
11391 			top = top->op_sibling;
11392 		    }
11393 		}
11394 	    }
11395 
11396 	    /* Optimise 'my $x; my $y;' into 'my ($x, $y);'
11397              *
11398 	     * This latter form is then suitable for conversion into padrange
11399 	     * later on. Convert:
11400 	     *
11401 	     *   nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3
11402 	     *
11403 	     * into:
11404 	     *
11405 	     *   nextstate1 ->     listop     -> nextstate3
11406 	     *                 /            \
11407 	     *         pushmark -> padop1 -> padop2
11408 	     */
11409 	    if (o->op_next && (
11410 		    o->op_next->op_type == OP_PADSV
11411 		 || o->op_next->op_type == OP_PADAV
11412 		 || o->op_next->op_type == OP_PADHV
11413 		)
11414 		&& !(o->op_next->op_private & ~OPpLVAL_INTRO)
11415 		&& o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE
11416 		&& o->op_next->op_next->op_next && (
11417 		    o->op_next->op_next->op_next->op_type == OP_PADSV
11418 		 || o->op_next->op_next->op_next->op_type == OP_PADAV
11419 		 || o->op_next->op_next->op_next->op_type == OP_PADHV
11420 		)
11421 		&& !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO)
11422 		&& o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE
11423 		&& (!CopLABEL((COP*)o)) /* Don't mess with labels */
11424 		&& (!CopLABEL((COP*)o->op_next->op_next)) /* ... */
11425 	    ) {
11426 		OP *first;
11427 		OP *last;
11428 		OP *newop;
11429 
11430 		first = o->op_next;
11431 		last = o->op_next->op_next->op_next;
11432 
11433 		newop = newLISTOP(OP_LIST, 0, first, last);
11434 		newop->op_flags |= OPf_PARENS;
11435 		newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11436 
11437 		/* Kill nextstate2 between padop1/padop2 */
11438 		op_free(first->op_next);
11439 
11440 		first->op_next = last;                /* padop2 */
11441 		first->op_sibling = last;             /* ... */
11442 		o->op_next = cUNOPx(newop)->op_first; /* pushmark */
11443 		o->op_next->op_next = first;          /* padop1 */
11444 		o->op_next->op_sibling = first;       /* ... */
11445 		newop->op_next = last->op_next;       /* nextstate3 */
11446 		newop->op_sibling = last->op_sibling;
11447 		last->op_next = newop;                /* listop */
11448 		last->op_sibling = NULL;
11449 		o->op_sibling = newop;                /* ... */
11450 
11451 		newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
11452 
11453 		/* Ensure pushmark has this flag if padops do */
11454 		if (first->op_flags & OPf_MOD && last->op_flags & OPf_MOD) {
11455 		    o->op_next->op_flags |= OPf_MOD;
11456 		}
11457 
11458 		break;
11459 	    }
11460 
11461 	    /* Two NEXTSTATEs in a row serve no purpose. Except if they happen
11462 	       to carry two labels. For now, take the easier option, and skip
11463 	       this optimisation if the first NEXTSTATE has a label.  */
11464 	    if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
11465 		OP *nextop = o->op_next;
11466 		while (nextop && nextop->op_type == OP_NULL)
11467 		    nextop = nextop->op_next;
11468 
11469 		if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
11470 		    COP *firstcop = (COP *)o;
11471 		    COP *secondcop = (COP *)nextop;
11472 		    /* We want the COP pointed to by o (and anything else) to
11473 		       become the next COP down the line.  */
11474 		    cop_free(firstcop);
11475 
11476 		    firstcop->op_next = secondcop->op_next;
11477 
11478 		    /* Now steal all its pointers, and duplicate the other
11479 		       data.  */
11480 		    firstcop->cop_line = secondcop->cop_line;
11481 #ifdef USE_ITHREADS
11482 		    firstcop->cop_stashoff = secondcop->cop_stashoff;
11483 		    firstcop->cop_file = secondcop->cop_file;
11484 #else
11485 		    firstcop->cop_stash = secondcop->cop_stash;
11486 		    firstcop->cop_filegv = secondcop->cop_filegv;
11487 #endif
11488 		    firstcop->cop_hints = secondcop->cop_hints;
11489 		    firstcop->cop_seq = secondcop->cop_seq;
11490 		    firstcop->cop_warnings = secondcop->cop_warnings;
11491 		    firstcop->cop_hints_hash = secondcop->cop_hints_hash;
11492 
11493 #ifdef USE_ITHREADS
11494 		    secondcop->cop_stashoff = 0;
11495 		    secondcop->cop_file = NULL;
11496 #else
11497 		    secondcop->cop_stash = NULL;
11498 		    secondcop->cop_filegv = NULL;
11499 #endif
11500 		    secondcop->cop_warnings = NULL;
11501 		    secondcop->cop_hints_hash = NULL;
11502 
11503 		    /* If we use op_null(), and hence leave an ex-COP, some
11504 		       warnings are misreported. For example, the compile-time
11505 		       error in 'use strict; no strict refs;'  */
11506 		    secondcop->op_type = OP_NULL;
11507 		    secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
11508 		}
11509 	    }
11510 	    break;
11511 
11512 	case OP_CONCAT:
11513 	    if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
11514 		if (o->op_next->op_private & OPpTARGET_MY) {
11515 		    if (o->op_flags & OPf_STACKED) /* chained concats */
11516 			break; /* ignore_optimization */
11517 		    else {
11518 			/* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
11519 			o->op_targ = o->op_next->op_targ;
11520 			o->op_next->op_targ = 0;
11521 			o->op_private |= OPpTARGET_MY;
11522 		    }
11523 		}
11524 		op_null(o->op_next);
11525 	    }
11526 	    break;
11527 	case OP_STUB:
11528 	    if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
11529 		break; /* Scalar stub must produce undef.  List stub is noop */
11530 	    }
11531 	    goto nothin;
11532 	case OP_NULL:
11533 	    if (o->op_targ == OP_NEXTSTATE
11534 		|| o->op_targ == OP_DBSTATE)
11535 	    {
11536 		PL_curcop = ((COP*)o);
11537 	    }
11538 	    /* XXX: We avoid setting op_seq here to prevent later calls
11539 	       to rpeep() from mistakenly concluding that optimisation
11540 	       has already occurred. This doesn't fix the real problem,
11541 	       though (See 20010220.007). AMS 20010719 */
11542 	    /* op_seq functionality is now replaced by op_opt */
11543 	    o->op_opt = 0;
11544 	    /* FALL THROUGH */
11545 	case OP_SCALAR:
11546 	case OP_LINESEQ:
11547 	case OP_SCOPE:
11548 	nothin:
11549 	    if (oldop) {
11550 		oldop->op_next = o->op_next;
11551 		o->op_opt = 0;
11552 		continue;
11553 	    }
11554 	    break;
11555 
11556         case OP_PUSHMARK:
11557 
11558             /* Convert a series of PAD ops for my vars plus support into a
11559              * single padrange op. Basically
11560              *
11561              *    pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
11562              *
11563              * becomes, depending on circumstances, one of
11564              *
11565              *    padrange  ----------------------------------> (list) -> rest
11566              *    padrange  --------------------------------------------> rest
11567              *
11568              * where all the pad indexes are sequential and of the same type
11569              * (INTRO or not).
11570              * We convert the pushmark into a padrange op, then skip
11571              * any other pad ops, and possibly some trailing ops.
11572              * Note that we don't null() the skipped ops, to make it
11573              * easier for Deparse to undo this optimisation (and none of
11574              * the skipped ops are holding any resourses). It also makes
11575              * it easier for find_uninit_var(), as it can just ignore
11576              * padrange, and examine the original pad ops.
11577              */
11578         {
11579             OP *p;
11580             OP *followop = NULL; /* the op that will follow the padrange op */
11581             U8 count = 0;
11582             U8 intro = 0;
11583             PADOFFSET base = 0; /* init only to stop compiler whining */
11584             U8 gimme       = 0; /* init only to stop compiler whining */
11585             bool defav = 0;  /* seen (...) = @_ */
11586             bool reuse = 0;  /* reuse an existing padrange op */
11587 
11588             /* look for a pushmark -> gv[_] -> rv2av */
11589 
11590             {
11591                 GV *gv;
11592                 OP *rv2av, *q;
11593                 p = o->op_next;
11594                 if (   p->op_type == OP_GV
11595                     && (gv = cGVOPx_gv(p))
11596                     && GvNAMELEN_get(gv) == 1
11597                     && *GvNAME_get(gv) == '_'
11598                     && GvSTASH(gv) == PL_defstash
11599                     && (rv2av = p->op_next)
11600                     && rv2av->op_type == OP_RV2AV
11601                     && !(rv2av->op_flags & OPf_REF)
11602                     && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
11603                     && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
11604                     && o->op_sibling == rv2av /* these two for Deparse */
11605                     && cUNOPx(rv2av)->op_first == p
11606                 ) {
11607                     q = rv2av->op_next;
11608                     if (q->op_type == OP_NULL)
11609                         q = q->op_next;
11610                     if (q->op_type == OP_PUSHMARK) {
11611                         defav = 1;
11612                         p = q;
11613                     }
11614                 }
11615             }
11616             if (!defav) {
11617                 /* To allow Deparse to pessimise this, it needs to be able
11618                  * to restore the pushmark's original op_next, which it
11619                  * will assume to be the same as op_sibling. */
11620                 if (o->op_next != o->op_sibling)
11621                     break;
11622                 p = o;
11623             }
11624 
11625             /* scan for PAD ops */
11626 
11627             for (p = p->op_next; p; p = p->op_next) {
11628                 if (p->op_type == OP_NULL)
11629                     continue;
11630 
11631                 if ((     p->op_type != OP_PADSV
11632                        && p->op_type != OP_PADAV
11633                        && p->op_type != OP_PADHV
11634                     )
11635                       /* any private flag other than INTRO? e.g. STATE */
11636                    || (p->op_private & ~OPpLVAL_INTRO)
11637                 )
11638                     break;
11639 
11640                 /* let $a[N] potentially be optimised into AELEMFAST_LEX
11641                  * instead */
11642                 if (   p->op_type == OP_PADAV
11643                     && p->op_next
11644                     && p->op_next->op_type == OP_CONST
11645                     && p->op_next->op_next
11646                     && p->op_next->op_next->op_type == OP_AELEM
11647                 )
11648                     break;
11649 
11650                 /* for 1st padop, note what type it is and the range
11651                  * start; for the others, check that it's the same type
11652                  * and that the targs are contiguous */
11653                 if (count == 0) {
11654                     intro = (p->op_private & OPpLVAL_INTRO);
11655                     base = p->op_targ;
11656                     gimme = (p->op_flags & OPf_WANT);
11657                 }
11658                 else {
11659                     if ((p->op_private & OPpLVAL_INTRO) != intro)
11660                         break;
11661                     /* Note that you'd normally  expect targs to be
11662                      * contiguous in my($a,$b,$c), but that's not the case
11663                      * when external modules start doing things, e.g.
11664                      i* Function::Parameters */
11665                     if (p->op_targ != base + count)
11666                         break;
11667                     assert(p->op_targ == base + count);
11668                     /* all the padops should be in the same context */
11669                     if (gimme != (p->op_flags & OPf_WANT))
11670                         break;
11671                 }
11672 
11673                 /* for AV, HV, only when we're not flattening */
11674                 if (   p->op_type != OP_PADSV
11675                     && gimme != OPf_WANT_VOID
11676                     && !(p->op_flags & OPf_REF)
11677                 )
11678                     break;
11679 
11680                 if (count >= OPpPADRANGE_COUNTMASK)
11681                     break;
11682 
11683                 /* there's a biggest base we can fit into a
11684                  * SAVEt_CLEARPADRANGE in pp_padrange */
11685                 if (intro && base >
11686                         (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
11687                     break;
11688 
11689                 /* Success! We've got another valid pad op to optimise away */
11690                 count++;
11691                 followop = p->op_next;
11692             }
11693 
11694             if (count < 1)
11695                 break;
11696 
11697             /* pp_padrange in specifically compile-time void context
11698              * skips pushing a mark and lexicals; in all other contexts
11699              * (including unknown till runtime) it pushes a mark and the
11700              * lexicals. We must be very careful then, that the ops we
11701              * optimise away would have exactly the same effect as the
11702              * padrange.
11703              * In particular in void context, we can only optimise to
11704              * a padrange if see see the complete sequence
11705              *     pushmark, pad*v, ...., list, nextstate
11706              * which has the net effect of of leaving the stack empty
11707              * (for now we leave the nextstate in the execution chain, for
11708              * its other side-effects).
11709              */
11710             assert(followop);
11711             if (gimme == OPf_WANT_VOID) {
11712                 if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
11713                         && gimme == (followop->op_flags & OPf_WANT)
11714                         && (   followop->op_next->op_type == OP_NEXTSTATE
11715                             || followop->op_next->op_type == OP_DBSTATE))
11716                 {
11717                     followop = followop->op_next; /* skip OP_LIST */
11718 
11719                     /* consolidate two successive my(...);'s */
11720 
11721                     if (   oldoldop
11722                         && oldoldop->op_type == OP_PADRANGE
11723                         && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
11724                         && (oldoldop->op_private & OPpLVAL_INTRO) == intro
11725                         && !(oldoldop->op_flags & OPf_SPECIAL)
11726                     ) {
11727                         U8 old_count;
11728                         assert(oldoldop->op_next == oldop);
11729                         assert(   oldop->op_type == OP_NEXTSTATE
11730                                || oldop->op_type == OP_DBSTATE);
11731                         assert(oldop->op_next == o);
11732 
11733                         old_count
11734                             = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
11735 
11736                        /* Do not assume pad offsets for $c and $d are con-
11737                           tiguous in
11738                             my ($a,$b,$c);
11739                             my ($d,$e,$f);
11740                         */
11741                         if (  oldoldop->op_targ + old_count == base
11742                            && old_count < OPpPADRANGE_COUNTMASK - count) {
11743                             base = oldoldop->op_targ;
11744                             count += old_count;
11745                             reuse = 1;
11746                         }
11747                     }
11748 
11749                     /* if there's any immediately following singleton
11750                      * my var's; then swallow them and the associated
11751                      * nextstates; i.e.
11752                      *    my ($a,$b); my $c; my $d;
11753                      * is treated as
11754                      *    my ($a,$b,$c,$d);
11755                      */
11756 
11757                     while (    ((p = followop->op_next))
11758                             && (  p->op_type == OP_PADSV
11759                                || p->op_type == OP_PADAV
11760                                || p->op_type == OP_PADHV)
11761                             && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
11762                             && (p->op_private & OPpLVAL_INTRO) == intro
11763                             && !(p->op_private & ~OPpLVAL_INTRO)
11764                             && p->op_next
11765                             && (   p->op_next->op_type == OP_NEXTSTATE
11766                                 || p->op_next->op_type == OP_DBSTATE)
11767                             && count < OPpPADRANGE_COUNTMASK
11768                             && base + count == p->op_targ
11769                     ) {
11770                         count++;
11771                         followop = p->op_next;
11772                     }
11773                 }
11774                 else
11775                     break;
11776             }
11777 
11778             if (reuse) {
11779                 assert(oldoldop->op_type == OP_PADRANGE);
11780                 oldoldop->op_next = followop;
11781                 oldoldop->op_private = (intro | count);
11782                 o = oldoldop;
11783                 oldop = NULL;
11784                 oldoldop = NULL;
11785             }
11786             else {
11787                 /* Convert the pushmark into a padrange.
11788                  * To make Deparse easier, we guarantee that a padrange was
11789                  * *always* formerly a pushmark */
11790                 assert(o->op_type == OP_PUSHMARK);
11791                 o->op_next = followop;
11792                 o->op_type = OP_PADRANGE;
11793                 o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
11794                 o->op_targ = base;
11795                 /* bit 7: INTRO; bit 6..0: count */
11796                 o->op_private = (intro | count);
11797                 o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
11798                                     | gimme | (defav ? OPf_SPECIAL : 0));
11799             }
11800             break;
11801         }
11802 
11803 	case OP_PADAV:
11804 	case OP_GV:
11805 	    if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
11806 		OP* const pop = (o->op_type == OP_PADAV) ?
11807 			    o->op_next : o->op_next->op_next;
11808 		IV i;
11809 		if (pop && pop->op_type == OP_CONST &&
11810 		    ((PL_op = pop->op_next)) &&
11811 		    pop->op_next->op_type == OP_AELEM &&
11812 		    !(pop->op_next->op_private &
11813 		      (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
11814 		    (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127)
11815 		{
11816 		    GV *gv;
11817 		    if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
11818 			no_bareword_allowed(pop);
11819 		    if (o->op_type == OP_GV)
11820 			op_null(o->op_next);
11821 		    op_null(pop->op_next);
11822 		    op_null(pop);
11823 		    o->op_flags |= pop->op_next->op_flags & OPf_MOD;
11824 		    o->op_next = pop->op_next->op_next;
11825 		    o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
11826 		    o->op_private = (U8)i;
11827 		    if (o->op_type == OP_GV) {
11828 			gv = cGVOPo_gv;
11829 			GvAVn(gv);
11830 			o->op_type = OP_AELEMFAST;
11831 		    }
11832 		    else
11833 			o->op_type = OP_AELEMFAST_LEX;
11834 		}
11835 		break;
11836 	    }
11837 
11838 	    if (o->op_next->op_type == OP_RV2SV) {
11839 		if (!(o->op_next->op_private & OPpDEREF)) {
11840 		    op_null(o->op_next);
11841 		    o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
11842 							       | OPpOUR_INTRO);
11843 		    o->op_next = o->op_next->op_next;
11844 		    o->op_type = OP_GVSV;
11845 		    o->op_ppaddr = PL_ppaddr[OP_GVSV];
11846 		}
11847 	    }
11848 	    else if (o->op_next->op_type == OP_READLINE
11849 		    && o->op_next->op_next->op_type == OP_CONCAT
11850 		    && (o->op_next->op_next->op_flags & OPf_STACKED))
11851 	    {
11852 		/* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
11853 		o->op_type   = OP_RCATLINE;
11854 		o->op_flags |= OPf_STACKED;
11855 		o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
11856 		op_null(o->op_next->op_next);
11857 		op_null(o->op_next);
11858 	    }
11859 
11860 	    break;
11861 
11862         {
11863             OP *fop;
11864             OP *sop;
11865 
11866 #define HV_OR_SCALARHV(op)                                   \
11867     (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
11868        ? (op)                                                  \
11869        : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
11870        && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
11871           || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
11872          ? cUNOPx(op)->op_first                                   \
11873          : NULL)
11874 
11875         case OP_NOT:
11876             if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
11877                 fop->op_private |= OPpTRUEBOOL;
11878             break;
11879 
11880         case OP_AND:
11881 	case OP_OR:
11882 	case OP_DOR:
11883             fop = cLOGOP->op_first;
11884             sop = fop->op_sibling;
11885 	    while (cLOGOP->op_other->op_type == OP_NULL)
11886 		cLOGOP->op_other = cLOGOP->op_other->op_next;
11887 	    while (o->op_next && (   o->op_type == o->op_next->op_type
11888 				  || o->op_next->op_type == OP_NULL))
11889 		o->op_next = o->op_next->op_next;
11890 
11891 	    /* if we're an OR and our next is a AND in void context, we'll
11892 	       follow it's op_other on short circuit, same for reverse.
11893 	       We can't do this with OP_DOR since if it's true, its return
11894 	       value is the underlying value which must be evaluated
11895 	       by the next op */
11896 	    if (o->op_next &&
11897 	        (
11898 		    (IS_AND_OP(o) && IS_OR_OP(o->op_next))
11899 	         || (IS_OR_OP(o) && IS_AND_OP(o->op_next))
11900 	        )
11901 	        && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
11902 	    ) {
11903 	        o->op_next = ((LOGOP*)o->op_next)->op_other;
11904 	    }
11905 	    DEFER(cLOGOP->op_other);
11906 
11907 	    o->op_opt = 1;
11908             fop = HV_OR_SCALARHV(fop);
11909             if (sop) sop = HV_OR_SCALARHV(sop);
11910             if (fop || sop
11911             ){
11912                 OP * nop = o;
11913                 OP * lop = o;
11914                 if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
11915                     while (nop && nop->op_next) {
11916                         switch (nop->op_next->op_type) {
11917                             case OP_NOT:
11918                             case OP_AND:
11919                             case OP_OR:
11920                             case OP_DOR:
11921                                 lop = nop = nop->op_next;
11922                                 break;
11923                             case OP_NULL:
11924                                 nop = nop->op_next;
11925                                 break;
11926                             default:
11927                                 nop = NULL;
11928                                 break;
11929                         }
11930                     }
11931                 }
11932                 if (fop) {
11933                     if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11934                       || o->op_type == OP_AND  )
11935                         fop->op_private |= OPpTRUEBOOL;
11936                     else if (!(lop->op_flags & OPf_WANT))
11937                         fop->op_private |= OPpMAYBE_TRUEBOOL;
11938                 }
11939                 if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
11940                    && sop)
11941                     sop->op_private |= OPpTRUEBOOL;
11942             }
11943 
11944 
11945 	    break;
11946 
11947 	case OP_COND_EXPR:
11948 	    if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
11949 		fop->op_private |= OPpTRUEBOOL;
11950 #undef HV_OR_SCALARHV
11951 	    /* GERONIMO! */
11952 	}
11953 
11954 	case OP_MAPWHILE:
11955 	case OP_GREPWHILE:
11956 	case OP_ANDASSIGN:
11957 	case OP_ORASSIGN:
11958 	case OP_DORASSIGN:
11959 	case OP_RANGE:
11960 	case OP_ONCE:
11961 	    while (cLOGOP->op_other->op_type == OP_NULL)
11962 		cLOGOP->op_other = cLOGOP->op_other->op_next;
11963 	    DEFER(cLOGOP->op_other);
11964 	    break;
11965 
11966 	case OP_ENTERLOOP:
11967 	case OP_ENTERITER:
11968 	    while (cLOOP->op_redoop->op_type == OP_NULL)
11969 		cLOOP->op_redoop = cLOOP->op_redoop->op_next;
11970 	    while (cLOOP->op_nextop->op_type == OP_NULL)
11971 		cLOOP->op_nextop = cLOOP->op_nextop->op_next;
11972 	    while (cLOOP->op_lastop->op_type == OP_NULL)
11973 		cLOOP->op_lastop = cLOOP->op_lastop->op_next;
11974 	    /* a while(1) loop doesn't have an op_next that escapes the
11975 	     * loop, so we have to explicitly follow the op_lastop to
11976 	     * process the rest of the code */
11977 	    DEFER(cLOOP->op_lastop);
11978 	    break;
11979 
11980         case OP_ENTERTRY:
11981 	    assert(cLOGOPo->op_other->op_type == OP_LEAVETRY);
11982 	    DEFER(cLOGOPo->op_other);
11983 	    break;
11984 
11985 	case OP_SUBST:
11986 	    assert(!(cPMOP->op_pmflags & PMf_ONCE));
11987 	    while (cPMOP->op_pmstashstartu.op_pmreplstart &&
11988 		   cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
11989 		cPMOP->op_pmstashstartu.op_pmreplstart
11990 		    = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
11991 	    DEFER(cPMOP->op_pmstashstartu.op_pmreplstart);
11992 	    break;
11993 
11994 	case OP_SORT: {
11995 	    OP *oright;
11996 
11997 	    if (o->op_flags & OPf_SPECIAL) {
11998                 /* first arg is a code block */
11999 		OP * const nullop = cLISTOP->op_first->op_sibling;
12000                 OP * kid          = cUNOPx(nullop)->op_first;
12001 
12002                 assert(nullop->op_type == OP_NULL);
12003 		assert(kid->op_type == OP_SCOPE
12004 		 || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE));
12005                 /* since OP_SORT doesn't have a handy op_other-style
12006                  * field that can point directly to the start of the code
12007                  * block, store it in the otherwise-unused op_next field
12008                  * of the top-level OP_NULL. This will be quicker at
12009                  * run-time, and it will also allow us to remove leading
12010                  * OP_NULLs by just messing with op_nexts without
12011                  * altering the basic op_first/op_sibling layout. */
12012                 kid = kLISTOP->op_first;
12013                 assert(
12014                       (kid->op_type == OP_NULL
12015                       && (  kid->op_targ == OP_NEXTSTATE
12016                          || kid->op_targ == OP_DBSTATE  ))
12017                     || kid->op_type == OP_STUB
12018                     || kid->op_type == OP_ENTER);
12019                 nullop->op_next = kLISTOP->op_next;
12020                 DEFER(nullop->op_next);
12021 	    }
12022 
12023 	    /* check that RHS of sort is a single plain array */
12024 	    oright = cUNOPo->op_first;
12025 	    if (!oright || oright->op_type != OP_PUSHMARK)
12026 		break;
12027 
12028 	    if (o->op_private & OPpSORT_INPLACE)
12029 		break;
12030 
12031 	    /* reverse sort ... can be optimised.  */
12032 	    if (!cUNOPo->op_sibling) {
12033 		/* Nothing follows us on the list. */
12034 		OP * const reverse = o->op_next;
12035 
12036 		if (reverse->op_type == OP_REVERSE &&
12037 		    (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
12038 		    OP * const pushmark = cUNOPx(reverse)->op_first;
12039 		    if (pushmark && (pushmark->op_type == OP_PUSHMARK)
12040 			&& (cUNOPx(pushmark)->op_sibling == o)) {
12041 			/* reverse -> pushmark -> sort */
12042 			o->op_private |= OPpSORT_REVERSE;
12043 			op_null(reverse);
12044 			pushmark->op_next = oright->op_next;
12045 			op_null(oright);
12046 		    }
12047 		}
12048 	    }
12049 
12050 	    break;
12051 	}
12052 
12053 	case OP_REVERSE: {
12054 	    OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
12055 	    OP *gvop = NULL;
12056 	    LISTOP *enter, *exlist;
12057 
12058 	    if (o->op_private & OPpSORT_INPLACE)
12059 		break;
12060 
12061 	    enter = (LISTOP *) o->op_next;
12062 	    if (!enter)
12063 		break;
12064 	    if (enter->op_type == OP_NULL) {
12065 		enter = (LISTOP *) enter->op_next;
12066 		if (!enter)
12067 		    break;
12068 	    }
12069 	    /* for $a (...) will have OP_GV then OP_RV2GV here.
12070 	       for (...) just has an OP_GV.  */
12071 	    if (enter->op_type == OP_GV) {
12072 		gvop = (OP *) enter;
12073 		enter = (LISTOP *) enter->op_next;
12074 		if (!enter)
12075 		    break;
12076 		if (enter->op_type == OP_RV2GV) {
12077 		  enter = (LISTOP *) enter->op_next;
12078 		  if (!enter)
12079 		    break;
12080 		}
12081 	    }
12082 
12083 	    if (enter->op_type != OP_ENTERITER)
12084 		break;
12085 
12086 	    iter = enter->op_next;
12087 	    if (!iter || iter->op_type != OP_ITER)
12088 		break;
12089 
12090 	    expushmark = enter->op_first;
12091 	    if (!expushmark || expushmark->op_type != OP_NULL
12092 		|| expushmark->op_targ != OP_PUSHMARK)
12093 		break;
12094 
12095 	    exlist = (LISTOP *) expushmark->op_sibling;
12096 	    if (!exlist || exlist->op_type != OP_NULL
12097 		|| exlist->op_targ != OP_LIST)
12098 		break;
12099 
12100 	    if (exlist->op_last != o) {
12101 		/* Mmm. Was expecting to point back to this op.  */
12102 		break;
12103 	    }
12104 	    theirmark = exlist->op_first;
12105 	    if (!theirmark || theirmark->op_type != OP_PUSHMARK)
12106 		break;
12107 
12108 	    if (theirmark->op_sibling != o) {
12109 		/* There's something between the mark and the reverse, eg
12110 		   for (1, reverse (...))
12111 		   so no go.  */
12112 		break;
12113 	    }
12114 
12115 	    ourmark = ((LISTOP *)o)->op_first;
12116 	    if (!ourmark || ourmark->op_type != OP_PUSHMARK)
12117 		break;
12118 
12119 	    ourlast = ((LISTOP *)o)->op_last;
12120 	    if (!ourlast || ourlast->op_next != o)
12121 		break;
12122 
12123 	    rv2av = ourmark->op_sibling;
12124 	    if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
12125 		&& rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
12126 		&& enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
12127 		/* We're just reversing a single array.  */
12128 		rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
12129 		enter->op_flags |= OPf_STACKED;
12130 	    }
12131 
12132 	    /* We don't have control over who points to theirmark, so sacrifice
12133 	       ours.  */
12134 	    theirmark->op_next = ourmark->op_next;
12135 	    theirmark->op_flags = ourmark->op_flags;
12136 	    ourlast->op_next = gvop ? gvop : (OP *) enter;
12137 	    op_null(ourmark);
12138 	    op_null(o);
12139 	    enter->op_private |= OPpITER_REVERSED;
12140 	    iter->op_private |= OPpITER_REVERSED;
12141 
12142 	    break;
12143 	}
12144 
12145 	case OP_QR:
12146 	case OP_MATCH:
12147 	    if (!(cPMOP->op_pmflags & PMf_ONCE)) {
12148 		assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
12149 	    }
12150 	    break;
12151 
12152 	case OP_RUNCV:
12153 	    if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
12154 		SV *sv;
12155 		if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
12156 		else {
12157 		    sv = newRV((SV *)PL_compcv);
12158 		    sv_rvweaken(sv);
12159 		    SvREADONLY_on(sv);
12160 		}
12161 		o->op_type = OP_CONST;
12162 		o->op_ppaddr = PL_ppaddr[OP_CONST];
12163 		o->op_flags |= OPf_SPECIAL;
12164 		cSVOPo->op_sv = sv;
12165 	    }
12166 	    break;
12167 
12168 	case OP_SASSIGN:
12169 	    if (OP_GIMME(o,0) == G_VOID) {
12170 		OP *right = cBINOP->op_first;
12171 		if (right) {
12172                     /*   sassign
12173                     *      RIGHT
12174                     *      substr
12175                     *         pushmark
12176                     *         arg1
12177                     *         arg2
12178                     *         ...
12179                     * becomes
12180                     *
12181                     *  ex-sassign
12182                     *     substr
12183                     *        pushmark
12184                     *        RIGHT
12185                     *        arg1
12186                     *        arg2
12187                     *        ...
12188                     */
12189 		    OP *left = right->op_sibling;
12190 		    if (left->op_type == OP_SUBSTR
12191 			 && (left->op_private & 7) < 4) {
12192 			op_null(o);
12193 			cBINOP->op_first = left;
12194 			right->op_sibling =
12195 			    cBINOPx(left)->op_first->op_sibling;
12196 			cBINOPx(left)->op_first->op_sibling = right;
12197 			left->op_private |= OPpSUBSTR_REPL_FIRST;
12198 			left->op_flags =
12199 			    (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
12200 		    }
12201 		}
12202 	    }
12203 	    break;
12204 
12205 	case OP_CUSTOM: {
12206 	    Perl_cpeep_t cpeep =
12207 		XopENTRYCUSTOM(o, xop_peep);
12208 	    if (cpeep)
12209 		cpeep(aTHX_ o, oldop);
12210 	    break;
12211 	}
12212 
12213 	}
12214         /* did we just null the current op? If so, re-process it to handle
12215          * eliding "empty" ops from the chain */
12216         if (o->op_type == OP_NULL && oldop && oldop->op_next == o) {
12217             o->op_opt = 0;
12218             o = oldop;
12219         }
12220         else {
12221             oldoldop = oldop;
12222             oldop = o;
12223         }
12224     }
12225     LEAVE;
12226 }
12227 
12228 void
12229 Perl_peep(pTHX_ OP *o)
12230 {
12231     CALL_RPEEP(o);
12232 }
12233 
12234 /*
12235 =head1 Custom Operators
12236 
12237 =for apidoc Ao||custom_op_xop
12238 Return the XOP structure for a given custom op.  This macro should be
12239 considered internal to OP_NAME and the other access macros: use them instead.
12240 This macro does call a function.  Prior
12241 to 5.19.6, this was implemented as a
12242 function.
12243 
12244 =cut
12245 */
12246 
12247 XOPRETANY
12248 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
12249 {
12250     SV *keysv;
12251     HE *he = NULL;
12252     XOP *xop;
12253 
12254     static const XOP xop_null = { 0, 0, 0, 0, 0 };
12255 
12256     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
12257     assert(o->op_type == OP_CUSTOM);
12258 
12259     /* This is wrong. It assumes a function pointer can be cast to IV,
12260      * which isn't guaranteed, but this is what the old custom OP code
12261      * did. In principle it should be safer to Copy the bytes of the
12262      * pointer into a PV: since the new interface is hidden behind
12263      * functions, this can be changed later if necessary.  */
12264     /* Change custom_op_xop if this ever happens */
12265     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
12266 
12267     if (PL_custom_ops)
12268 	he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
12269 
12270     /* assume noone will have just registered a desc */
12271     if (!he && PL_custom_op_names &&
12272 	(he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
12273     ) {
12274 	const char *pv;
12275 	STRLEN l;
12276 
12277 	/* XXX does all this need to be shared mem? */
12278 	Newxz(xop, 1, XOP);
12279 	pv = SvPV(HeVAL(he), l);
12280 	XopENTRY_set(xop, xop_name, savepvn(pv, l));
12281 	if (PL_custom_op_descs &&
12282 	    (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
12283 	) {
12284 	    pv = SvPV(HeVAL(he), l);
12285 	    XopENTRY_set(xop, xop_desc, savepvn(pv, l));
12286 	}
12287 	Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
12288     }
12289     else {
12290 	if (!he)
12291 	    xop = (XOP *)&xop_null;
12292 	else
12293 	    xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
12294     }
12295     {
12296 	XOPRETANY any;
12297 	if(field == XOPe_xop_ptr) {
12298 	    any.xop_ptr = xop;
12299 	} else {
12300 	    const U32 flags = XopFLAGS(xop);
12301 	    if(flags & field) {
12302 		switch(field) {
12303 		case XOPe_xop_name:
12304 		    any.xop_name = xop->xop_name;
12305 		    break;
12306 		case XOPe_xop_desc:
12307 		    any.xop_desc = xop->xop_desc;
12308 		    break;
12309 		case XOPe_xop_class:
12310 		    any.xop_class = xop->xop_class;
12311 		    break;
12312 		case XOPe_xop_peep:
12313 		    any.xop_peep = xop->xop_peep;
12314 		    break;
12315 		default:
12316 		    NOT_REACHED;
12317 		    break;
12318 		}
12319 	    } else {
12320 		switch(field) {
12321 		case XOPe_xop_name:
12322 		    any.xop_name = XOPd_xop_name;
12323 		    break;
12324 		case XOPe_xop_desc:
12325 		    any.xop_desc = XOPd_xop_desc;
12326 		    break;
12327 		case XOPe_xop_class:
12328 		    any.xop_class = XOPd_xop_class;
12329 		    break;
12330 		case XOPe_xop_peep:
12331 		    any.xop_peep = XOPd_xop_peep;
12332 		    break;
12333 		default:
12334 		    NOT_REACHED;
12335 		    break;
12336 		}
12337 	    }
12338 	}
12339 	return any;
12340     }
12341 }
12342 
12343 /*
12344 =for apidoc Ao||custom_op_register
12345 Register a custom op.  See L<perlguts/"Custom Operators">.
12346 
12347 =cut
12348 */
12349 
12350 void
12351 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
12352 {
12353     SV *keysv;
12354 
12355     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
12356 
12357     /* see the comment in custom_op_xop */
12358     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
12359 
12360     if (!PL_custom_ops)
12361 	PL_custom_ops = newHV();
12362 
12363     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
12364 	Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
12365 }
12366 
12367 /*
12368 =head1 Functions in file op.c
12369 
12370 =for apidoc core_prototype
12371 This function assigns the prototype of the named core function to C<sv>, or
12372 to a new mortal SV if C<sv> is NULL.  It returns the modified C<sv>, or
12373 NULL if the core function has no prototype.  C<code> is a code as returned
12374 by C<keyword()>.  It must not be equal to 0.
12375 
12376 =cut
12377 */
12378 
12379 SV *
12380 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
12381                           int * const opnum)
12382 {
12383     int i = 0, n = 0, seen_question = 0, defgv = 0;
12384     I32 oa;
12385 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
12386     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
12387     bool nullret = FALSE;
12388 
12389     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
12390 
12391     assert (code);
12392 
12393     if (!sv) sv = sv_newmortal();
12394 
12395 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
12396 
12397     switch (code < 0 ? -code : code) {
12398     case KEY_and   : case KEY_chop: case KEY_chomp:
12399     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
12400     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
12401     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
12402     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
12403     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
12404     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
12405     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
12406     case KEY_x     : case KEY_xor    :
12407 	if (!opnum) return NULL; nullret = TRUE; goto findopnum;
12408     case KEY_glob:    retsetpvs("_;", OP_GLOB);
12409     case KEY_keys:    retsetpvs("+", OP_KEYS);
12410     case KEY_values:  retsetpvs("+", OP_VALUES);
12411     case KEY_each:    retsetpvs("+", OP_EACH);
12412     case KEY_push:    retsetpvs("+@", OP_PUSH);
12413     case KEY_unshift: retsetpvs("+@", OP_UNSHIFT);
12414     case KEY_pop:     retsetpvs(";+", OP_POP);
12415     case KEY_shift:   retsetpvs(";+", OP_SHIFT);
12416     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
12417     case KEY_splice:
12418 	retsetpvs("+;$$@", OP_SPLICE);
12419     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
12420 	retsetpvs("", 0);
12421     case KEY_evalbytes:
12422 	name = "entereval"; break;
12423     case KEY_readpipe:
12424 	name = "backtick";
12425     }
12426 
12427 #undef retsetpvs
12428 
12429   findopnum:
12430     while (i < MAXO) {	/* The slow way. */
12431 	if (strEQ(name, PL_op_name[i])
12432 	    || strEQ(name, PL_op_desc[i]))
12433 	{
12434 	    if (nullret) { assert(opnum); *opnum = i; return NULL; }
12435 	    goto found;
12436 	}
12437 	i++;
12438     }
12439     return NULL;
12440   found:
12441     defgv = PL_opargs[i] & OA_DEFGV;
12442     oa = PL_opargs[i] >> OASHIFT;
12443     while (oa) {
12444 	if (oa & OA_OPTIONAL && !seen_question && (
12445 	      !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
12446 	)) {
12447 	    seen_question = 1;
12448 	    str[n++] = ';';
12449 	}
12450 	if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
12451 	    && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
12452 	    /* But globs are already references (kinda) */
12453 	    && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
12454 	) {
12455 	    str[n++] = '\\';
12456 	}
12457 	if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
12458 	 && !scalar_mod_type(NULL, i)) {
12459 	    str[n++] = '[';
12460 	    str[n++] = '$';
12461 	    str[n++] = '@';
12462 	    str[n++] = '%';
12463 	    if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
12464 	    str[n++] = '*';
12465 	    str[n++] = ']';
12466 	}
12467 	else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
12468 	if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
12469 	    str[n-1] = '_'; defgv = 0;
12470 	}
12471 	oa = oa >> 4;
12472     }
12473     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
12474     str[n++] = '\0';
12475     sv_setpvn(sv, str, n - 1);
12476     if (opnum) *opnum = i;
12477     return sv;
12478 }
12479 
12480 OP *
12481 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
12482                       const int opnum)
12483 {
12484     OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
12485     OP *o;
12486 
12487     PERL_ARGS_ASSERT_CORESUB_OP;
12488 
12489     switch(opnum) {
12490     case 0:
12491 	return op_append_elem(OP_LINESEQ,
12492 	               argop,
12493 	               newSLICEOP(0,
12494 	                          newSVOP(OP_CONST, 0, newSViv(-code % 3)),
12495 	                          newOP(OP_CALLER,0)
12496 	               )
12497 	       );
12498     case OP_SELECT: /* which represents OP_SSELECT as well */
12499 	if (code)
12500 	    return newCONDOP(
12501 	                 0,
12502 	                 newBINOP(OP_GT, 0,
12503 	                          newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
12504 	                          newSVOP(OP_CONST, 0, newSVuv(1))
12505 	                         ),
12506 	                 coresub_op(newSVuv((UV)OP_SSELECT), 0,
12507 	                            OP_SSELECT),
12508 	                 coresub_op(coreargssv, 0, OP_SELECT)
12509 	           );
12510 	/* FALL THROUGH */
12511     default:
12512 	switch (PL_opargs[opnum] & OA_CLASS_MASK) {
12513 	case OA_BASEOP:
12514 	    return op_append_elem(
12515 	                OP_LINESEQ, argop,
12516 	                newOP(opnum,
12517 	                      opnum == OP_WANTARRAY || opnum == OP_RUNCV
12518 	                        ? OPpOFFBYONE << 8 : 0)
12519 	           );
12520 	case OA_BASEOP_OR_UNOP:
12521 	    if (opnum == OP_ENTEREVAL) {
12522 		o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
12523 		if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
12524 	    }
12525 	    else o = newUNOP(opnum,0,argop);
12526 	    if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
12527 	    else {
12528 	  onearg:
12529 	      if (is_handle_constructor(o, 1))
12530 		argop->op_private |= OPpCOREARGS_DEREF1;
12531 	      if (scalar_mod_type(NULL, opnum))
12532 		argop->op_private |= OPpCOREARGS_SCALARMOD;
12533 	    }
12534 	    return o;
12535 	default:
12536 	    o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
12537 	    if (is_handle_constructor(o, 2))
12538 		argop->op_private |= OPpCOREARGS_DEREF2;
12539 	    if (opnum == OP_SUBSTR) {
12540 		o->op_private |= OPpMAYBE_LVSUB;
12541 		return o;
12542 	    }
12543 	    else goto onearg;
12544 	}
12545     }
12546 }
12547 
12548 void
12549 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
12550 			       SV * const *new_const_svp)
12551 {
12552     const char *hvname;
12553     bool is_const = !!CvCONST(old_cv);
12554     SV *old_const_sv = is_const ? cv_const_sv(old_cv) : NULL;
12555 
12556     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
12557 
12558     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
12559 	return;
12560 	/* They are 2 constant subroutines generated from
12561 	   the same constant. This probably means that
12562 	   they are really the "same" proxy subroutine
12563 	   instantiated in 2 places. Most likely this is
12564 	   when a constant is exported twice.  Don't warn.
12565 	*/
12566     if (
12567 	(ckWARN(WARN_REDEFINE)
12568 	 && !(
12569 		CvGV(old_cv) && GvSTASH(CvGV(old_cv))
12570 	     && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
12571 	     && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
12572 		 strEQ(hvname, "autouse"))
12573 	     )
12574 	)
12575      || (is_const
12576 	 && ckWARN_d(WARN_REDEFINE)
12577 	 && (!new_const_svp || sv_cmp(old_const_sv, *new_const_svp))
12578 	)
12579     )
12580 	Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
12581 			  is_const
12582 			    ? "Constant subroutine %"SVf" redefined"
12583 			    : "Subroutine %"SVf" redefined",
12584 			  name);
12585 }
12586 
12587 /*
12588 =head1 Hook manipulation
12589 
12590 These functions provide convenient and thread-safe means of manipulating
12591 hook variables.
12592 
12593 =cut
12594 */
12595 
12596 /*
12597 =for apidoc Am|void|wrap_op_checker|Optype opcode|Perl_check_t new_checker|Perl_check_t *old_checker_p
12598 
12599 Puts a C function into the chain of check functions for a specified op
12600 type.  This is the preferred way to manipulate the L</PL_check> array.
12601 I<opcode> specifies which type of op is to be affected.  I<new_checker>
12602 is a pointer to the C function that is to be added to that opcode's
12603 check chain, and I<old_checker_p> points to the storage location where a
12604 pointer to the next function in the chain will be stored.  The value of
12605 I<new_pointer> is written into the L</PL_check> array, while the value
12606 previously stored there is written to I<*old_checker_p>.
12607 
12608 The function should be defined like this:
12609 
12610     static OP *new_checker(pTHX_ OP *op) { ... }
12611 
12612 It is intended to be called in this manner:
12613 
12614     new_checker(aTHX_ op)
12615 
12616 I<old_checker_p> should be defined like this:
12617 
12618     static Perl_check_t old_checker_p;
12619 
12620 L</PL_check> is global to an entire process, and a module wishing to
12621 hook op checking may find itself invoked more than once per process,
12622 typically in different threads.  To handle that situation, this function
12623 is idempotent.  The location I<*old_checker_p> must initially (once
12624 per process) contain a null pointer.  A C variable of static duration
12625 (declared at file scope, typically also marked C<static> to give
12626 it internal linkage) will be implicitly initialised appropriately,
12627 if it does not have an explicit initialiser.  This function will only
12628 actually modify the check chain if it finds I<*old_checker_p> to be null.
12629 This function is also thread safe on the small scale.  It uses appropriate
12630 locking to avoid race conditions in accessing L</PL_check>.
12631 
12632 When this function is called, the function referenced by I<new_checker>
12633 must be ready to be called, except for I<*old_checker_p> being unfilled.
12634 In a threading situation, I<new_checker> may be called immediately,
12635 even before this function has returned.  I<*old_checker_p> will always
12636 be appropriately set before I<new_checker> is called.  If I<new_checker>
12637 decides not to do anything special with an op that it is given (which
12638 is the usual case for most uses of op check hooking), it must chain the
12639 check function referenced by I<*old_checker_p>.
12640 
12641 If you want to influence compilation of calls to a specific subroutine,
12642 then use L</cv_set_call_checker> rather than hooking checking of all
12643 C<entersub> ops.
12644 
12645 =cut
12646 */
12647 
12648 void
12649 Perl_wrap_op_checker(pTHX_ Optype opcode,
12650     Perl_check_t new_checker, Perl_check_t *old_checker_p)
12651 {
12652     dVAR;
12653 
12654     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
12655     if (*old_checker_p) return;
12656     OP_CHECK_MUTEX_LOCK;
12657     if (!*old_checker_p) {
12658 	*old_checker_p = PL_check[opcode];
12659 	PL_check[opcode] = new_checker;
12660     }
12661     OP_CHECK_MUTEX_UNLOCK;
12662 }
12663 
12664 #include "XSUB.h"
12665 
12666 /* Efficient sub that returns a constant scalar value. */
12667 static void
12668 const_sv_xsub(pTHX_ CV* cv)
12669 {
12670     dVAR;
12671     dXSARGS;
12672     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
12673     PERL_UNUSED_ARG(items);
12674     if (!sv) {
12675 	XSRETURN(0);
12676     }
12677     EXTEND(sp, 1);
12678     ST(0) = sv;
12679     XSRETURN(1);
12680 }
12681 
12682 static void
12683 const_av_xsub(pTHX_ CV* cv)
12684 {
12685     dVAR;
12686     dXSARGS;
12687     AV * const av = MUTABLE_AV(XSANY.any_ptr);
12688     SP -= items;
12689     assert(av);
12690 #ifndef DEBUGGING
12691     if (!av) {
12692 	XSRETURN(0);
12693     }
12694 #endif
12695     if (SvRMAGICAL(av))
12696 	Perl_croak(aTHX_ "Magical list constants are not supported");
12697     if (GIMME_V != G_ARRAY) {
12698 	EXTEND(SP, 1);
12699 	ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
12700 	XSRETURN(1);
12701     }
12702     EXTEND(SP, AvFILLp(av)+1);
12703     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
12704     XSRETURN(AvFILLp(av)+1);
12705 }
12706 
12707 /*
12708  * Local variables:
12709  * c-indentation-style: bsd
12710  * c-basic-offset: 4
12711  * indent-tabs-mode: nil
12712  * End:
12713  *
12714  * ex: set ts=8 sts=4 sw=4 et:
12715  */
12716