This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make Perl_op_linklist() non-recursive
[perl5.git] / op.c
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  * Note that during the build of miniperl, a temporary copy of this file
26  * is made, called opmini.c.
27  *
28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
29  *  * structural OP pointers to its children and siblings (op_sibling,
30  *    op_first etc) that define the tree structure;
31  *  * execution order OP pointers (op_next, plus sometimes op_other,
32  *    op_lastop  etc) that define the execution sequence plus variants;
33  *  * a pointer to the C "pp" function that would execute the op;
34  *  * any data specific to that op.
35  * For example, an OP_CONST op points to the pp_const() function and to an
36  * SV containing the constant value. When pp_const() is executed, its job
37  * is to push that SV onto the stack.
38  *
39  * OPs are mainly created by the newFOO() functions, which are mainly
40  * called from the parser (in perly.y) as the code is parsed. For example
41  * the Perl code $a + $b * $c would cause the equivalent of the following
42  * to be called (oversimplifying a bit):
43  *
44  *  newBINOP(OP_ADD, flags,
45  *      newSVREF($a),
46  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
47  *  )
48  *
49  * As the parser reduces low-level rules, it creates little op subtrees;
50  * as higher-level rules are resolved, these subtrees get joined together
51  * as branches on a bigger subtree, until eventually a top-level rule like
52  * a subroutine definition is reduced, at which point there is one large
53  * parse tree left.
54  *
55  * The execution order pointers (op_next) are generated as the subtrees
56  * are joined together. Consider this sub-expression: A*B + C/D: at the
57  * point when it's just been parsed, the op tree looks like:
58  *
59  *   [+]
60  *    |
61  *   [*]------[/]
62  *    |        |
63  *    A---B    C---D
64  *
65  * with the intended execution order being:
66  *
67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
68  *
69  * At this point all the nodes' op_next pointers will have been set,
70  * except that:
71  *    * we don't know what the [NEXT] node will be yet;
72  *    * we don't know what the [PREV] node will be yet, but when it gets
73  *      created and needs its op_next set, it needs to be set to point to
74  *      A, which is non-obvious.
75  * To handle both those cases, we temporarily set the top node's
76  * op_next to point to the first node to be executed in this subtree (A in
77  * this case). This means that initially a subtree's op_next chain,
78  * starting from the top node, will visit each node in execution sequence
79  * then point back at the top node.
80  * When we embed this subtree in a larger tree, its top op_next is used
81  * to get the start node, then is set to point to its new neighbour.
82  * For example the two separate [*],A,B and [/],C,D subtrees would
83  * initially have had:
84  *   [*] => A;  A => B;  B => [*]
85  * and
86  *   [/] => C;  C => D;  D => [/]
87  * When these two subtrees were joined together to make the [+] subtree,
88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89  * set to point to [/]'s op_next, i.e. C.
90  *
91  * This op_next linking is done by the LINKLIST() macro and its underlying
92  * op_linklist() function. Given a top-level op, if its op_next is
93  * non-null, it's already been linked, so leave it. Otherwise link it with
94  * its children as described above, possibly recursively if any of the
95  * children have a null op_next.
96  *
97  * In summary: given a subtree, its top-level node's op_next will either
98  * be:
99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
100  *   fake: points to the start op for this subtree;
101  *   real: once the subtree has been embedded into a larger tree
102  */
103
104 /*
105
106 Here's an older description from Larry.
107
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
109
110     A bottom-up pass
111     A top-down pass
112     An execution-order pass
113
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines.  The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order.  (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
121 top level node.)
122
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again).  As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node.  But
130 it's still not the real execution order.
131
132 The actual execution order is not known till we get a grammar reduction
133 to a top-level unit like a subroutine or file that will be called by
134 "name" rather than via a "next" pointer.  At that point, we can call
135 into peep() to do that code's portion of the 3rd pass.  It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
137 */
138
139 /* To implement user lexical pragmas, there needs to be a way at run time to
140    get the compile time state of %^H for that block.  Storing %^H in every
141    block (or even COP) would be very expensive, so a different approach is
142    taken.  The (running) state of %^H is serialised into a tree of HE-like
143    structs.  Stores into %^H are chained onto the current leaf as a struct
144    refcounted_he * with the key and the value.  Deletes from %^H are saved
145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
146    turned back into a regular HV by walking back up the tree from that point's
147    leaf, ignoring any key you've already seen (placeholder or not), storing
148    the rest into the HV structure, then removing the placeholders. Hence
149    memory is only used to store the %^H deltas from the enclosing COP, rather
150    than the entire %^H on each COP.
151
152    To cause actions on %^H to write out the serialisation records, it has
153    magic type 'H'. This magic (itself) does nothing, but its presence causes
154    the values to gain magic type 'h', which has entries for set and clear.
155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158    it will be correctly restored when any inner compiling scope is exited.
159 */
160
161 #include "EXTERN.h"
162 #define PERL_IN_OP_C
163 #include "perl.h"
164 #include "keywords.h"
165 #include "feature.h"
166 #include "regcomp.h"
167
168 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
169 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
171
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
173
174 /* remove any leading "empty" ops from the op_next chain whose first
175  * node's address is stored in op_p. Store the updated address of the
176  * first node in op_p.
177  */
178
179 STATIC void
180 S_prune_chain_head(OP** op_p)
181 {
182     while (*op_p
183         && (   (*op_p)->op_type == OP_NULL
184             || (*op_p)->op_type == OP_SCOPE
185             || (*op_p)->op_type == OP_SCALAR
186             || (*op_p)->op_type == OP_LINESEQ)
187     )
188         *op_p = (*op_p)->op_next;
189 }
190
191
192 /* See the explanatory comments above struct opslab in op.h. */
193
194 #ifdef PERL_DEBUG_READONLY_OPS
195 #  define PERL_SLAB_SIZE 128
196 #  define PERL_MAX_SLAB_SIZE 4096
197 #  include <sys/mman.h>
198 #endif
199
200 #ifndef PERL_SLAB_SIZE
201 #  define PERL_SLAB_SIZE 64
202 #endif
203 #ifndef PERL_MAX_SLAB_SIZE
204 #  define PERL_MAX_SLAB_SIZE 2048
205 #endif
206
207 /* rounds up to nearest pointer */
208 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
209 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
210
211 /* malloc a new op slab (suitable for attaching to PL_compcv) */
212
213 static OPSLAB *
214 S_new_slab(pTHX_ size_t sz)
215 {
216 #ifdef PERL_DEBUG_READONLY_OPS
217     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
218                                    PROT_READ|PROT_WRITE,
219                                    MAP_ANON|MAP_PRIVATE, -1, 0);
220     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
221                           (unsigned long) sz, slab));
222     if (slab == MAP_FAILED) {
223         perror("mmap failed");
224         abort();
225     }
226     slab->opslab_size = (U16)sz;
227 #else
228     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
229 #endif
230 #ifndef WIN32
231     /* The context is unused in non-Windows */
232     PERL_UNUSED_CONTEXT;
233 #endif
234     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
235     return slab;
236 }
237
238 /* requires double parens and aTHX_ */
239 #define DEBUG_S_warn(args)                                             \
240     DEBUG_S(                                                            \
241         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
242     )
243
244 /* Returns a sz-sized block of memory (suitable for holding an op) from
245  * a free slot in the chain of op slabs attached to PL_compcv.
246  * Allocates a new slab if necessary.
247  * if PL_compcv isn't compiling, malloc() instead.
248  */
249
250 void *
251 Perl_Slab_Alloc(pTHX_ size_t sz)
252 {
253     OPSLAB *slab;
254     OPSLAB *slab2;
255     OPSLOT *slot;
256     OP *o;
257     size_t opsz, space;
258
259     /* We only allocate ops from the slab during subroutine compilation.
260        We find the slab via PL_compcv, hence that must be non-NULL. It could
261        also be pointing to a subroutine which is now fully set up (CvROOT()
262        pointing to the top of the optree for that sub), or a subroutine
263        which isn't using the slab allocator. If our sanity checks aren't met,
264        don't use a slab, but allocate the OP directly from the heap.  */
265     if (!PL_compcv || CvROOT(PL_compcv)
266      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
267     {
268         o = (OP*)PerlMemShared_calloc(1, sz);
269         goto gotit;
270     }
271
272     /* While the subroutine is under construction, the slabs are accessed via
273        CvSTART(), to avoid needing to expand PVCV by one pointer for something
274        unneeded at runtime. Once a subroutine is constructed, the slabs are
275        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
276        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
277        details.  */
278     if (!CvSTART(PL_compcv)) {
279         CvSTART(PL_compcv) =
280             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
281         CvSLABBED_on(PL_compcv);
282         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
283     }
284     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
285
286     opsz = SIZE_TO_PSIZE(sz);
287     sz = opsz + OPSLOT_HEADER_P;
288
289     /* The slabs maintain a free list of OPs. In particular, constant folding
290        will free up OPs, so it makes sense to re-use them where possible. A
291        freed up slot is used in preference to a new allocation.  */
292     if (slab->opslab_freed) {
293         OP **too = &slab->opslab_freed;
294         o = *too;
295         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
296         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
297             DEBUG_S_warn((aTHX_ "Alas! too small"));
298             o = *(too = &o->op_next);
299             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
300         }
301         if (o) {
302             *too = o->op_next;
303             Zero(o, opsz, I32 *);
304             o->op_slabbed = 1;
305             goto gotit;
306         }
307     }
308
309 #define INIT_OPSLOT \
310             slot->opslot_slab = slab;                   \
311             slot->opslot_next = slab2->opslab_first;    \
312             slab2->opslab_first = slot;                 \
313             o = &slot->opslot_op;                       \
314             o->op_slabbed = 1
315
316     /* The partially-filled slab is next in the chain. */
317     slab2 = slab->opslab_next ? slab->opslab_next : slab;
318     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
319         /* Remaining space is too small. */
320
321         /* If we can fit a BASEOP, add it to the free chain, so as not
322            to waste it. */
323         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
324             slot = &slab2->opslab_slots;
325             INIT_OPSLOT;
326             o->op_type = OP_FREED;
327             o->op_next = slab->opslab_freed;
328             slab->opslab_freed = o;
329         }
330
331         /* Create a new slab.  Make this one twice as big. */
332         slot = slab2->opslab_first;
333         while (slot->opslot_next) slot = slot->opslot_next;
334         slab2 = S_new_slab(aTHX_
335                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
336                                         ? PERL_MAX_SLAB_SIZE
337                                         : (DIFF(slab2, slot)+1)*2);
338         slab2->opslab_next = slab->opslab_next;
339         slab->opslab_next = slab2;
340     }
341     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
342
343     /* Create a new op slot */
344     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
345     assert(slot >= &slab2->opslab_slots);
346     if (DIFF(&slab2->opslab_slots, slot)
347          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
348         slot = &slab2->opslab_slots;
349     INIT_OPSLOT;
350     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
351
352   gotit:
353     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
354     assert(!o->op_moresib);
355     assert(!o->op_sibparent);
356
357     return (void *)o;
358 }
359
360 #undef INIT_OPSLOT
361
362 #ifdef PERL_DEBUG_READONLY_OPS
363 void
364 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
365 {
366     PERL_ARGS_ASSERT_SLAB_TO_RO;
367
368     if (slab->opslab_readonly) return;
369     slab->opslab_readonly = 1;
370     for (; slab; slab = slab->opslab_next) {
371         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
372                               (unsigned long) slab->opslab_size, slab));*/
373         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
374             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
375                              (unsigned long)slab->opslab_size, errno);
376     }
377 }
378
379 void
380 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
381 {
382     OPSLAB *slab2;
383
384     PERL_ARGS_ASSERT_SLAB_TO_RW;
385
386     if (!slab->opslab_readonly) return;
387     slab2 = slab;
388     for (; slab2; slab2 = slab2->opslab_next) {
389         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
390                               (unsigned long) size, slab2));*/
391         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
392                      PROT_READ|PROT_WRITE)) {
393             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
394                              (unsigned long)slab2->opslab_size, errno);
395         }
396     }
397     slab->opslab_readonly = 0;
398 }
399
400 #else
401 #  define Slab_to_rw(op)    NOOP
402 #endif
403
404 /* This cannot possibly be right, but it was copied from the old slab
405    allocator, to which it was originally added, without explanation, in
406    commit 083fcd5. */
407 #ifdef NETWARE
408 #    define PerlMemShared PerlMem
409 #endif
410
411 /* make freed ops die if they're inadvertently executed */
412 #ifdef DEBUGGING
413 static OP *
414 S_pp_freed(pTHX)
415 {
416     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
417 }
418 #endif
419
420
421 /* Return the block of memory used by an op to the free list of
422  * the OP slab associated with that op.
423  */
424
425 void
426 Perl_Slab_Free(pTHX_ void *op)
427 {
428     OP * const o = (OP *)op;
429     OPSLAB *slab;
430
431     PERL_ARGS_ASSERT_SLAB_FREE;
432
433 #ifdef DEBUGGING
434     o->op_ppaddr = S_pp_freed;
435 #endif
436
437     if (!o->op_slabbed) {
438         if (!o->op_static)
439             PerlMemShared_free(op);
440         return;
441     }
442
443     slab = OpSLAB(o);
444     /* If this op is already freed, our refcount will get screwy. */
445     assert(o->op_type != OP_FREED);
446     o->op_type = OP_FREED;
447     o->op_next = slab->opslab_freed;
448     slab->opslab_freed = o;
449     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
450     OpslabREFCNT_dec_padok(slab);
451 }
452
453 void
454 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
455 {
456     const bool havepad = !!PL_comppad;
457     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
458     if (havepad) {
459         ENTER;
460         PAD_SAVE_SETNULLPAD();
461     }
462     opslab_free(slab);
463     if (havepad) LEAVE;
464 }
465
466 /* Free a chain of OP slabs. Should only be called after all ops contained
467  * in it have been freed. At this point, its reference count should be 1,
468  * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
469  * and just directly calls opslab_free().
470  * (Note that the reference count which PL_compcv held on the slab should
471  * have been removed once compilation of the sub was complete).
472  *
473  *
474  */
475
476 void
477 Perl_opslab_free(pTHX_ OPSLAB *slab)
478 {
479     OPSLAB *slab2;
480     PERL_ARGS_ASSERT_OPSLAB_FREE;
481     PERL_UNUSED_CONTEXT;
482     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
483     assert(slab->opslab_refcnt == 1);
484     do {
485         slab2 = slab->opslab_next;
486 #ifdef DEBUGGING
487         slab->opslab_refcnt = ~(size_t)0;
488 #endif
489 #ifdef PERL_DEBUG_READONLY_OPS
490         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
491                                                (void*)slab));
492         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
493             perror("munmap failed");
494             abort();
495         }
496 #else
497         PerlMemShared_free(slab);
498 #endif
499         slab = slab2;
500     } while (slab);
501 }
502
503 /* like opslab_free(), but first calls op_free() on any ops in the slab
504  * not marked as OP_FREED
505  */
506
507 void
508 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
509 {
510     OPSLAB *slab2;
511 #ifdef DEBUGGING
512     size_t savestack_count = 0;
513 #endif
514     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
515     slab2 = slab;
516     do {
517         OPSLOT *slot;
518         for (slot = slab2->opslab_first;
519              slot->opslot_next;
520              slot = slot->opslot_next) {
521             if (slot->opslot_op.op_type != OP_FREED
522              && !(slot->opslot_op.op_savefree
523 #ifdef DEBUGGING
524                   && ++savestack_count
525 #endif
526                  )
527             ) {
528                 assert(slot->opslot_op.op_slabbed);
529                 op_free(&slot->opslot_op);
530                 if (slab->opslab_refcnt == 1) goto free;
531             }
532         }
533     } while ((slab2 = slab2->opslab_next));
534     /* > 1 because the CV still holds a reference count. */
535     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
536 #ifdef DEBUGGING
537         assert(savestack_count == slab->opslab_refcnt-1);
538 #endif
539         /* Remove the CV’s reference count. */
540         slab->opslab_refcnt--;
541         return;
542     }
543    free:
544     opslab_free(slab);
545 }
546
547 #ifdef PERL_DEBUG_READONLY_OPS
548 OP *
549 Perl_op_refcnt_inc(pTHX_ OP *o)
550 {
551     if(o) {
552         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
553         if (slab && slab->opslab_readonly) {
554             Slab_to_rw(slab);
555             ++o->op_targ;
556             Slab_to_ro(slab);
557         } else {
558             ++o->op_targ;
559         }
560     }
561     return o;
562
563 }
564
565 PADOFFSET
566 Perl_op_refcnt_dec(pTHX_ OP *o)
567 {
568     PADOFFSET result;
569     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
570
571     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
572
573     if (slab && slab->opslab_readonly) {
574         Slab_to_rw(slab);
575         result = --o->op_targ;
576         Slab_to_ro(slab);
577     } else {
578         result = --o->op_targ;
579     }
580     return result;
581 }
582 #endif
583 /*
584  * In the following definition, the ", (OP*)0" is just to make the compiler
585  * think the expression is of the right type: croak actually does a Siglongjmp.
586  */
587 #define CHECKOP(type,o) \
588     ((PL_op_mask && PL_op_mask[type])                           \
589      ? ( op_free((OP*)o),                                       \
590          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
591          (OP*)0 )                                               \
592      : PL_check[type](aTHX_ (OP*)o))
593
594 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
595
596 #define OpTYPE_set(o,type) \
597     STMT_START {                                \
598         o->op_type = (OPCODE)type;              \
599         o->op_ppaddr = PL_ppaddr[type];         \
600     } STMT_END
601
602 STATIC OP *
603 S_no_fh_allowed(pTHX_ OP *o)
604 {
605     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
606
607     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
608                  OP_DESC(o)));
609     return o;
610 }
611
612 STATIC OP *
613 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
614 {
615     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
616     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
617     return o;
618 }
619  
620 STATIC OP *
621 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
622 {
623     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
624
625     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
626     return o;
627 }
628
629 STATIC void
630 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
631 {
632     PERL_ARGS_ASSERT_BAD_TYPE_PV;
633
634     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
635                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
636 }
637
638 /* remove flags var, its unused in all callers, move to to right end since gv
639   and kid are always the same */
640 STATIC void
641 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
642 {
643     SV * const namesv = cv_name((CV *)gv, NULL, 0);
644     PERL_ARGS_ASSERT_BAD_TYPE_GV;
645  
646     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
647                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
648 }
649
650 STATIC void
651 S_no_bareword_allowed(pTHX_ OP *o)
652 {
653     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
654
655     qerror(Perl_mess(aTHX_
656                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
657                      SVfARG(cSVOPo_sv)));
658     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
659 }
660
661 /* "register" allocation */
662
663 PADOFFSET
664 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
665 {
666     PADOFFSET off;
667     const bool is_our = (PL_parser->in_my == KEY_our);
668
669     PERL_ARGS_ASSERT_ALLOCMY;
670
671     if (flags & ~SVf_UTF8)
672         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
673                    (UV)flags);
674
675     /* complain about "my $<special_var>" etc etc */
676     if (   len
677         && !(  is_our
678             || isALPHA(name[1])
679             || (   (flags & SVf_UTF8)
680                 && isIDFIRST_utf8_safe((U8 *)name+1, name + len))
681             || (name[1] == '_' && len > 2)))
682     {
683         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
684          && isASCII(name[1])
685          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
686             /* diag_listed_as: Can't use global %s in "%s" */
687             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
688                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
689                               PL_parser->in_my == KEY_state ? "state" : "my"));
690         } else {
691             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
692                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
693         }
694     }
695
696     /* allocate a spare slot and store the name in that slot */
697
698     off = pad_add_name_pvn(name, len,
699                        (is_our ? padadd_OUR :
700                         PL_parser->in_my == KEY_state ? padadd_STATE : 0),
701                     PL_parser->in_my_stash,
702                     (is_our
703                         /* $_ is always in main::, even with our */
704                         ? (PL_curstash && !memEQs(name,len,"$_")
705                             ? PL_curstash
706                             : PL_defstash)
707                         : NULL
708                     )
709     );
710     /* anon sub prototypes contains state vars should always be cloned,
711      * otherwise the state var would be shared between anon subs */
712
713     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
714         CvCLONE_on(PL_compcv);
715
716     return off;
717 }
718
719 /*
720 =head1 Optree Manipulation Functions
721
722 =for apidoc alloccopstash
723
724 Available only under threaded builds, this function allocates an entry in
725 C<PL_stashpad> for the stash passed to it.
726
727 =cut
728 */
729
730 #ifdef USE_ITHREADS
731 PADOFFSET
732 Perl_alloccopstash(pTHX_ HV *hv)
733 {
734     PADOFFSET off = 0, o = 1;
735     bool found_slot = FALSE;
736
737     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
738
739     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
740
741     for (; o < PL_stashpadmax; ++o) {
742         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
743         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
744             found_slot = TRUE, off = o;
745     }
746     if (!found_slot) {
747         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
748         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
749         off = PL_stashpadmax;
750         PL_stashpadmax += 10;
751     }
752
753     PL_stashpad[PL_stashpadix = off] = hv;
754     return off;
755 }
756 #endif
757
758 /* free the body of an op without examining its contents.
759  * Always use this rather than FreeOp directly */
760
761 static void
762 S_op_destroy(pTHX_ OP *o)
763 {
764     FreeOp(o);
765 }
766
767 /* Destructor */
768
769 /*
770 =for apidoc op_free
771
772 Free an op and its children. Only use this when an op is no longer linked
773 to from any optree.
774
775 =cut
776 */
777
778 void
779 Perl_op_free(pTHX_ OP *o)
780 {
781     dVAR;
782     OPCODE type;
783     OP *top_op = o;
784     OP *next_op = o;
785     bool went_up = FALSE; /* whether we reached the current node by
786                             following the parent pointer from a child, and
787                             so have already seen this node */
788
789     if (!o || o->op_type == OP_FREED)
790         return;
791
792     if (o->op_private & OPpREFCOUNTED) {
793         /* if base of tree is refcounted, just decrement */
794         switch (o->op_type) {
795         case OP_LEAVESUB:
796         case OP_LEAVESUBLV:
797         case OP_LEAVEEVAL:
798         case OP_LEAVE:
799         case OP_SCOPE:
800         case OP_LEAVEWRITE:
801             {
802                 PADOFFSET refcnt;
803                 OP_REFCNT_LOCK;
804                 refcnt = OpREFCNT_dec(o);
805                 OP_REFCNT_UNLOCK;
806                 if (refcnt) {
807                     /* Need to find and remove any pattern match ops from
808                      * the list we maintain for reset().  */
809                     find_and_forget_pmops(o);
810                     return;
811                 }
812             }
813             break;
814         default:
815             break;
816         }
817     }
818
819     while (next_op) {
820         o = next_op;
821
822         /* free child ops before ourself, (then free ourself "on the
823          * way back up") */
824
825         if (!went_up && o->op_flags & OPf_KIDS) {
826             next_op = cUNOPo->op_first;
827             continue;
828         }
829
830         /* find the next node to visit, *then* free the current node
831          * (can't rely on o->op_* fields being valid after o has been
832          * freed) */
833
834         /* The next node to visit will be either the sibling, or the
835          * parent if no siblings left, or NULL if we've worked our way
836          * back up to the top node in the tree */
837         next_op = (o == top_op) ? NULL : o->op_sibparent;
838         went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
839
840         /* Now process the current node */
841
842         /* Though ops may be freed twice, freeing the op after its slab is a
843            big no-no. */
844         assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
845         /* During the forced freeing of ops after compilation failure, kidops
846            may be freed before their parents. */
847         if (!o || o->op_type == OP_FREED)
848             continue;
849
850         type = o->op_type;
851
852         /* an op should only ever acquire op_private flags that we know about.
853          * If this fails, you may need to fix something in regen/op_private.
854          * Don't bother testing if:
855          *   * the op_ppaddr doesn't match the op; someone may have
856          *     overridden the op and be doing strange things with it;
857          *   * we've errored, as op flags are often left in an
858          *     inconsistent state then. Note that an error when
859          *     compiling the main program leaves PL_parser NULL, so
860          *     we can't spot faults in the main code, only
861          *     evaled/required code */
862 #ifdef DEBUGGING
863         if (   o->op_ppaddr == PL_ppaddr[type]
864             && PL_parser
865             && !PL_parser->error_count)
866         {
867             assert(!(o->op_private & ~PL_op_private_valid[type]));
868         }
869 #endif
870
871
872         /* Call the op_free hook if it has been set. Do it now so that it's called
873          * at the right time for refcounted ops, but still before all of the kids
874          * are freed. */
875         CALL_OPFREEHOOK(o);
876
877         if (type == OP_NULL)
878             type = (OPCODE)o->op_targ;
879
880         if (o->op_slabbed)
881             Slab_to_rw(OpSLAB(o));
882
883         /* COP* is not cleared by op_clear() so that we may track line
884          * numbers etc even after null() */
885         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
886             cop_free((COP*)o);
887         }
888
889         op_clear(o);
890         FreeOp(o);
891         if (PL_op == o)
892             PL_op = NULL;
893     }
894 }
895
896
897 /* S_op_clear_gv(): free a GV attached to an OP */
898
899 STATIC
900 #ifdef USE_ITHREADS
901 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
902 #else
903 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
904 #endif
905 {
906
907     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
908             || o->op_type == OP_MULTIDEREF)
909 #ifdef USE_ITHREADS
910                 && PL_curpad
911                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
912 #else
913                 ? (GV*)(*svp) : NULL;
914 #endif
915     /* It's possible during global destruction that the GV is freed
916        before the optree. Whilst the SvREFCNT_inc is happy to bump from
917        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
918        will trigger an assertion failure, because the entry to sv_clear
919        checks that the scalar is not already freed.  A check of for
920        !SvIS_FREED(gv) turns out to be invalid, because during global
921        destruction the reference count can be forced down to zero
922        (with SVf_BREAK set).  In which case raising to 1 and then
923        dropping to 0 triggers cleanup before it should happen.  I
924        *think* that this might actually be a general, systematic,
925        weakness of the whole idea of SVf_BREAK, in that code *is*
926        allowed to raise and lower references during global destruction,
927        so any *valid* code that happens to do this during global
928        destruction might well trigger premature cleanup.  */
929     bool still_valid = gv && SvREFCNT(gv);
930
931     if (still_valid)
932         SvREFCNT_inc_simple_void(gv);
933 #ifdef USE_ITHREADS
934     if (*ixp > 0) {
935         pad_swipe(*ixp, TRUE);
936         *ixp = 0;
937     }
938 #else
939     SvREFCNT_dec(*svp);
940     *svp = NULL;
941 #endif
942     if (still_valid) {
943         int try_downgrade = SvREFCNT(gv) == 2;
944         SvREFCNT_dec_NN(gv);
945         if (try_downgrade)
946             gv_try_downgrade(gv);
947     }
948 }
949
950
951 void
952 Perl_op_clear(pTHX_ OP *o)
953 {
954
955     dVAR;
956
957     PERL_ARGS_ASSERT_OP_CLEAR;
958
959     switch (o->op_type) {
960     case OP_NULL:       /* Was holding old type, if any. */
961         /* FALLTHROUGH */
962     case OP_ENTERTRY:
963     case OP_ENTEREVAL:  /* Was holding hints. */
964     case OP_ARGDEFELEM: /* Was holding signature index. */
965         o->op_targ = 0;
966         break;
967     default:
968         if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
969             break;
970         /* FALLTHROUGH */
971     case OP_GVSV:
972     case OP_GV:
973     case OP_AELEMFAST:
974 #ifdef USE_ITHREADS
975             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
976 #else
977             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
978 #endif
979         break;
980     case OP_METHOD_REDIR:
981     case OP_METHOD_REDIR_SUPER:
982 #ifdef USE_ITHREADS
983         if (cMETHOPx(o)->op_rclass_targ) {
984             pad_swipe(cMETHOPx(o)->op_rclass_targ, 1);
985             cMETHOPx(o)->op_rclass_targ = 0;
986         }
987 #else
988         SvREFCNT_dec(cMETHOPx(o)->op_rclass_sv);
989         cMETHOPx(o)->op_rclass_sv = NULL;
990 #endif
991         /* FALLTHROUGH */
992     case OP_METHOD_NAMED:
993     case OP_METHOD_SUPER:
994         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
995         cMETHOPx(o)->op_u.op_meth_sv = NULL;
996 #ifdef USE_ITHREADS
997         if (o->op_targ) {
998             pad_swipe(o->op_targ, 1);
999             o->op_targ = 0;
1000         }
1001 #endif
1002         break;
1003     case OP_CONST:
1004     case OP_HINTSEVAL:
1005         SvREFCNT_dec(cSVOPo->op_sv);
1006         cSVOPo->op_sv = NULL;
1007 #ifdef USE_ITHREADS
1008         /** Bug #15654
1009           Even if op_clear does a pad_free for the target of the op,
1010           pad_free doesn't actually remove the sv that exists in the pad;
1011           instead it lives on. This results in that it could be reused as 
1012           a target later on when the pad was reallocated.
1013         **/
1014         if(o->op_targ) {
1015           pad_swipe(o->op_targ,1);
1016           o->op_targ = 0;
1017         }
1018 #endif
1019         break;
1020     case OP_DUMP:
1021     case OP_GOTO:
1022     case OP_NEXT:
1023     case OP_LAST:
1024     case OP_REDO:
1025         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1026             break;
1027         /* FALLTHROUGH */
1028     case OP_TRANS:
1029     case OP_TRANSR:
1030         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1031             && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
1032         {
1033 #ifdef USE_ITHREADS
1034             if (cPADOPo->op_padix > 0) {
1035                 pad_swipe(cPADOPo->op_padix, TRUE);
1036                 cPADOPo->op_padix = 0;
1037             }
1038 #else
1039             SvREFCNT_dec(cSVOPo->op_sv);
1040             cSVOPo->op_sv = NULL;
1041 #endif
1042         }
1043         else {
1044             PerlMemShared_free(cPVOPo->op_pv);
1045             cPVOPo->op_pv = NULL;
1046         }
1047         break;
1048     case OP_SUBST:
1049         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1050         goto clear_pmop;
1051
1052     case OP_SPLIT:
1053         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1054             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1055         {
1056             if (o->op_private & OPpSPLIT_LEX)
1057                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1058             else
1059 #ifdef USE_ITHREADS
1060                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1061 #else
1062                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1063 #endif
1064         }
1065         /* FALLTHROUGH */
1066     case OP_MATCH:
1067     case OP_QR:
1068     clear_pmop:
1069         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1070             op_free(cPMOPo->op_code_list);
1071         cPMOPo->op_code_list = NULL;
1072         forget_pmop(cPMOPo);
1073         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1074         /* we use the same protection as the "SAFE" version of the PM_ macros
1075          * here since sv_clean_all might release some PMOPs
1076          * after PL_regex_padav has been cleared
1077          * and the clearing of PL_regex_padav needs to
1078          * happen before sv_clean_all
1079          */
1080 #ifdef USE_ITHREADS
1081         if(PL_regex_pad) {        /* We could be in destruction */
1082             const IV offset = (cPMOPo)->op_pmoffset;
1083             ReREFCNT_dec(PM_GETRE(cPMOPo));
1084             PL_regex_pad[offset] = &PL_sv_undef;
1085             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1086                            sizeof(offset));
1087         }
1088 #else
1089         ReREFCNT_dec(PM_GETRE(cPMOPo));
1090         PM_SETRE(cPMOPo, NULL);
1091 #endif
1092
1093         break;
1094
1095     case OP_ARGCHECK:
1096         PerlMemShared_free(cUNOP_AUXo->op_aux);
1097         break;
1098
1099     case OP_MULTICONCAT:
1100         {
1101             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1102             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1103              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1104              * utf8 shared strings */
1105             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1106             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1107             if (p1)
1108                 PerlMemShared_free(p1);
1109             if (p2 && p1 != p2)
1110                 PerlMemShared_free(p2);
1111             PerlMemShared_free(aux);
1112         }
1113         break;
1114
1115     case OP_MULTIDEREF:
1116         {
1117             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1118             UV actions = items->uv;
1119             bool last = 0;
1120             bool is_hash = FALSE;
1121
1122             while (!last) {
1123                 switch (actions & MDEREF_ACTION_MASK) {
1124
1125                 case MDEREF_reload:
1126                     actions = (++items)->uv;
1127                     continue;
1128
1129                 case MDEREF_HV_padhv_helem:
1130                     is_hash = TRUE;
1131                     /* FALLTHROUGH */
1132                 case MDEREF_AV_padav_aelem:
1133                     pad_free((++items)->pad_offset);
1134                     goto do_elem;
1135
1136                 case MDEREF_HV_gvhv_helem:
1137                     is_hash = TRUE;
1138                     /* FALLTHROUGH */
1139                 case MDEREF_AV_gvav_aelem:
1140 #ifdef USE_ITHREADS
1141                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1142 #else
1143                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1144 #endif
1145                     goto do_elem;
1146
1147                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1148                     is_hash = TRUE;
1149                     /* FALLTHROUGH */
1150                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1151 #ifdef USE_ITHREADS
1152                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1153 #else
1154                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1155 #endif
1156                     goto do_vivify_rv2xv_elem;
1157
1158                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1159                     is_hash = TRUE;
1160                     /* FALLTHROUGH */
1161                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1162                     pad_free((++items)->pad_offset);
1163                     goto do_vivify_rv2xv_elem;
1164
1165                 case MDEREF_HV_pop_rv2hv_helem:
1166                 case MDEREF_HV_vivify_rv2hv_helem:
1167                     is_hash = TRUE;
1168                     /* FALLTHROUGH */
1169                 do_vivify_rv2xv_elem:
1170                 case MDEREF_AV_pop_rv2av_aelem:
1171                 case MDEREF_AV_vivify_rv2av_aelem:
1172                 do_elem:
1173                     switch (actions & MDEREF_INDEX_MASK) {
1174                     case MDEREF_INDEX_none:
1175                         last = 1;
1176                         break;
1177                     case MDEREF_INDEX_const:
1178                         if (is_hash) {
1179 #ifdef USE_ITHREADS
1180                             /* see RT #15654 */
1181                             pad_swipe((++items)->pad_offset, 1);
1182 #else
1183                             SvREFCNT_dec((++items)->sv);
1184 #endif
1185                         }
1186                         else
1187                             items++;
1188                         break;
1189                     case MDEREF_INDEX_padsv:
1190                         pad_free((++items)->pad_offset);
1191                         break;
1192                     case MDEREF_INDEX_gvsv:
1193 #ifdef USE_ITHREADS
1194                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1195 #else
1196                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1197 #endif
1198                         break;
1199                     }
1200
1201                     if (actions & MDEREF_FLAG_last)
1202                         last = 1;
1203                     is_hash = FALSE;
1204
1205                     break;
1206
1207                 default:
1208                     assert(0);
1209                     last = 1;
1210                     break;
1211
1212                 } /* switch */
1213
1214                 actions >>= MDEREF_SHIFT;
1215             } /* while */
1216
1217             /* start of malloc is at op_aux[-1], where the length is
1218              * stored */
1219             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1220         }
1221         break;
1222     }
1223
1224     if (o->op_targ > 0) {
1225         pad_free(o->op_targ);
1226         o->op_targ = 0;
1227     }
1228 }
1229
1230 STATIC void
1231 S_cop_free(pTHX_ COP* cop)
1232 {
1233     PERL_ARGS_ASSERT_COP_FREE;
1234
1235     CopFILE_free(cop);
1236     if (! specialWARN(cop->cop_warnings))
1237         PerlMemShared_free(cop->cop_warnings);
1238     cophh_free(CopHINTHASH_get(cop));
1239     if (PL_curcop == cop)
1240        PL_curcop = NULL;
1241 }
1242
1243 STATIC void
1244 S_forget_pmop(pTHX_ PMOP *const o)
1245 {
1246     HV * const pmstash = PmopSTASH(o);
1247
1248     PERL_ARGS_ASSERT_FORGET_PMOP;
1249
1250     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1251         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1252         if (mg) {
1253             PMOP **const array = (PMOP**) mg->mg_ptr;
1254             U32 count = mg->mg_len / sizeof(PMOP**);
1255             U32 i = count;
1256
1257             while (i--) {
1258                 if (array[i] == o) {
1259                     /* Found it. Move the entry at the end to overwrite it.  */
1260                     array[i] = array[--count];
1261                     mg->mg_len = count * sizeof(PMOP**);
1262                     /* Could realloc smaller at this point always, but probably
1263                        not worth it. Probably worth free()ing if we're the
1264                        last.  */
1265                     if(!count) {
1266                         Safefree(mg->mg_ptr);
1267                         mg->mg_ptr = NULL;
1268                     }
1269                     break;
1270                 }
1271             }
1272         }
1273     }
1274     if (PL_curpm == o) 
1275         PL_curpm = NULL;
1276 }
1277
1278 STATIC void
1279 S_find_and_forget_pmops(pTHX_ OP *o)
1280 {
1281     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1282
1283     if (o->op_flags & OPf_KIDS) {
1284         OP *kid = cUNOPo->op_first;
1285         while (kid) {
1286             switch (kid->op_type) {
1287             case OP_SUBST:
1288             case OP_SPLIT:
1289             case OP_MATCH:
1290             case OP_QR:
1291                 forget_pmop((PMOP*)kid);
1292             }
1293             find_and_forget_pmops(kid);
1294             kid = OpSIBLING(kid);
1295         }
1296     }
1297 }
1298
1299 /*
1300 =for apidoc op_null
1301
1302 Neutralizes an op when it is no longer needed, but is still linked to from
1303 other ops.
1304
1305 =cut
1306 */
1307
1308 void
1309 Perl_op_null(pTHX_ OP *o)
1310 {
1311     dVAR;
1312
1313     PERL_ARGS_ASSERT_OP_NULL;
1314
1315     if (o->op_type == OP_NULL)
1316         return;
1317     op_clear(o);
1318     o->op_targ = o->op_type;
1319     OpTYPE_set(o, OP_NULL);
1320 }
1321
1322 void
1323 Perl_op_refcnt_lock(pTHX)
1324   PERL_TSA_ACQUIRE(PL_op_mutex)
1325 {
1326 #ifdef USE_ITHREADS
1327     dVAR;
1328 #endif
1329     PERL_UNUSED_CONTEXT;
1330     OP_REFCNT_LOCK;
1331 }
1332
1333 void
1334 Perl_op_refcnt_unlock(pTHX)
1335   PERL_TSA_RELEASE(PL_op_mutex)
1336 {
1337 #ifdef USE_ITHREADS
1338     dVAR;
1339 #endif
1340     PERL_UNUSED_CONTEXT;
1341     OP_REFCNT_UNLOCK;
1342 }
1343
1344
1345 /*
1346 =for apidoc op_sibling_splice
1347
1348 A general function for editing the structure of an existing chain of
1349 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1350 you to delete zero or more sequential nodes, replacing them with zero or
1351 more different nodes.  Performs the necessary op_first/op_last
1352 housekeeping on the parent node and op_sibling manipulation on the
1353 children.  The last deleted node will be marked as as the last node by
1354 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1355
1356 Note that op_next is not manipulated, and nodes are not freed; that is the
1357 responsibility of the caller.  It also won't create a new list op for an
1358 empty list etc; use higher-level functions like op_append_elem() for that.
1359
1360 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1361 the splicing doesn't affect the first or last op in the chain.
1362
1363 C<start> is the node preceding the first node to be spliced.  Node(s)
1364 following it will be deleted, and ops will be inserted after it.  If it is
1365 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1366 beginning.
1367
1368 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1369 If -1 or greater than or equal to the number of remaining kids, all
1370 remaining kids are deleted.
1371
1372 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1373 If C<NULL>, no nodes are inserted.
1374
1375 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1376 deleted.
1377
1378 For example:
1379
1380     action                    before      after         returns
1381     ------                    -----       -----         -------
1382
1383                               P           P
1384     splice(P, A, 2, X-Y-Z)    |           |             B-C
1385                               A-B-C-D     A-X-Y-Z-D
1386
1387                               P           P
1388     splice(P, NULL, 1, X-Y)   |           |             A
1389                               A-B-C-D     X-Y-B-C-D
1390
1391                               P           P
1392     splice(P, NULL, 3, NULL)  |           |             A-B-C
1393                               A-B-C-D     D
1394
1395                               P           P
1396     splice(P, B, 0, X-Y)      |           |             NULL
1397                               A-B-C-D     A-B-X-Y-C-D
1398
1399
1400 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1401 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1402
1403 =cut
1404 */
1405
1406 OP *
1407 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1408 {
1409     OP *first;
1410     OP *rest;
1411     OP *last_del = NULL;
1412     OP *last_ins = NULL;
1413
1414     if (start)
1415         first = OpSIBLING(start);
1416     else if (!parent)
1417         goto no_parent;
1418     else
1419         first = cLISTOPx(parent)->op_first;
1420
1421     assert(del_count >= -1);
1422
1423     if (del_count && first) {
1424         last_del = first;
1425         while (--del_count && OpHAS_SIBLING(last_del))
1426             last_del = OpSIBLING(last_del);
1427         rest = OpSIBLING(last_del);
1428         OpLASTSIB_set(last_del, NULL);
1429     }
1430     else
1431         rest = first;
1432
1433     if (insert) {
1434         last_ins = insert;
1435         while (OpHAS_SIBLING(last_ins))
1436             last_ins = OpSIBLING(last_ins);
1437         OpMAYBESIB_set(last_ins, rest, NULL);
1438     }
1439     else
1440         insert = rest;
1441
1442     if (start) {
1443         OpMAYBESIB_set(start, insert, NULL);
1444     }
1445     else {
1446         assert(parent);
1447         cLISTOPx(parent)->op_first = insert;
1448         if (insert)
1449             parent->op_flags |= OPf_KIDS;
1450         else
1451             parent->op_flags &= ~OPf_KIDS;
1452     }
1453
1454     if (!rest) {
1455         /* update op_last etc */
1456         U32 type;
1457         OP *lastop;
1458
1459         if (!parent)
1460             goto no_parent;
1461
1462         /* ought to use OP_CLASS(parent) here, but that can't handle
1463          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1464          * either */
1465         type = parent->op_type;
1466         if (type == OP_CUSTOM) {
1467             dTHX;
1468             type = XopENTRYCUSTOM(parent, xop_class);
1469         }
1470         else {
1471             if (type == OP_NULL)
1472                 type = parent->op_targ;
1473             type = PL_opargs[type] & OA_CLASS_MASK;
1474         }
1475
1476         lastop = last_ins ? last_ins : start ? start : NULL;
1477         if (   type == OA_BINOP
1478             || type == OA_LISTOP
1479             || type == OA_PMOP
1480             || type == OA_LOOP
1481         )
1482             cLISTOPx(parent)->op_last = lastop;
1483
1484         if (lastop)
1485             OpLASTSIB_set(lastop, parent);
1486     }
1487     return last_del ? first : NULL;
1488
1489   no_parent:
1490     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1491 }
1492
1493 /*
1494 =for apidoc op_parent
1495
1496 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1497
1498 =cut
1499 */
1500
1501 OP *
1502 Perl_op_parent(OP *o)
1503 {
1504     PERL_ARGS_ASSERT_OP_PARENT;
1505     while (OpHAS_SIBLING(o))
1506         o = OpSIBLING(o);
1507     return o->op_sibparent;
1508 }
1509
1510 /* replace the sibling following start with a new UNOP, which becomes
1511  * the parent of the original sibling; e.g.
1512  *
1513  *  op_sibling_newUNOP(P, A, unop-args...)
1514  *
1515  *  P              P
1516  *  |      becomes |
1517  *  A-B-C          A-U-C
1518  *                   |
1519  *                   B
1520  *
1521  * where U is the new UNOP.
1522  *
1523  * parent and start args are the same as for op_sibling_splice();
1524  * type and flags args are as newUNOP().
1525  *
1526  * Returns the new UNOP.
1527  */
1528
1529 STATIC OP *
1530 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1531 {
1532     OP *kid, *newop;
1533
1534     kid = op_sibling_splice(parent, start, 1, NULL);
1535     newop = newUNOP(type, flags, kid);
1536     op_sibling_splice(parent, start, 0, newop);
1537     return newop;
1538 }
1539
1540
1541 /* lowest-level newLOGOP-style function - just allocates and populates
1542  * the struct. Higher-level stuff should be done by S_new_logop() /
1543  * newLOGOP(). This function exists mainly to avoid op_first assignment
1544  * being spread throughout this file.
1545  */
1546
1547 LOGOP *
1548 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1549 {
1550     dVAR;
1551     LOGOP *logop;
1552     OP *kid = first;
1553     NewOp(1101, logop, 1, LOGOP);
1554     OpTYPE_set(logop, type);
1555     logop->op_first = first;
1556     logop->op_other = other;
1557     if (first)
1558         logop->op_flags = OPf_KIDS;
1559     while (kid && OpHAS_SIBLING(kid))
1560         kid = OpSIBLING(kid);
1561     if (kid)
1562         OpLASTSIB_set(kid, (OP*)logop);
1563     return logop;
1564 }
1565
1566
1567 /* Contextualizers */
1568
1569 /*
1570 =for apidoc op_contextualize
1571
1572 Applies a syntactic context to an op tree representing an expression.
1573 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_ARRAY>,
1574 or C<G_VOID> to specify the context to apply.  The modified op tree
1575 is returned.
1576
1577 =cut
1578 */
1579
1580 OP *
1581 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1582 {
1583     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1584     switch (context) {
1585         case G_SCALAR: return scalar(o);
1586         case G_ARRAY:  return list(o);
1587         case G_VOID:   return scalarvoid(o);
1588         default:
1589             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1590                        (long) context);
1591     }
1592 }
1593
1594 /*
1595
1596 =for apidoc op_linklist
1597 This function is the implementation of the L</LINKLIST> macro.  It should
1598 not be called directly.
1599
1600 =cut
1601 */
1602
1603
1604 OP *
1605 Perl_op_linklist(pTHX_ OP *o)
1606 {
1607
1608     OP **prevp;
1609     OP *kid;
1610     OP * top_op = o;
1611
1612     PERL_ARGS_ASSERT_OP_LINKLIST;
1613
1614     while (1) {
1615         /* Descend down the tree looking for any unprocessed subtrees to
1616          * do first */
1617         if (!o->op_next) {
1618             if (o->op_flags & OPf_KIDS) {
1619                 o = cUNOPo->op_first;
1620                 continue;
1621             }
1622             o->op_next = o; /* leaf node; link to self initially */
1623         }
1624
1625         /* if we're at the top level, there either weren't any children
1626          * to process, or we've worked our way back to the top. */
1627         if (o == top_op)
1628             return o->op_next;
1629
1630         /* o is now processed. Next, process any sibling subtrees */
1631
1632         if (OpHAS_SIBLING(o)) {
1633             o = OpSIBLING(o);
1634             continue;
1635         }
1636
1637         /* Done all the subtrees at this level. Go back up a level and
1638          * link the parent in with all its (processed) children.
1639          */
1640
1641         o = o->op_sibparent;
1642         assert(!o->op_next);
1643         prevp = &(o->op_next);
1644         kid   = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1645         while (kid) {
1646             *prevp = kid->op_next;
1647             prevp = &(kid->op_next);
1648             kid = OpSIBLING(kid);
1649         }
1650         *prevp = o;
1651     }
1652 }
1653
1654
1655 static OP *
1656 S_scalarkids(pTHX_ OP *o)
1657 {
1658     if (o && o->op_flags & OPf_KIDS) {
1659         OP *kid;
1660         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1661             scalar(kid);
1662     }
1663     return o;
1664 }
1665
1666 STATIC OP *
1667 S_scalarboolean(pTHX_ OP *o)
1668 {
1669     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1670
1671     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1672          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1673         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1674          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1675          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1676         if (ckWARN(WARN_SYNTAX)) {
1677             const line_t oldline = CopLINE(PL_curcop);
1678
1679             if (PL_parser && PL_parser->copline != NOLINE) {
1680                 /* This ensures that warnings are reported at the first line
1681                    of the conditional, not the last.  */
1682                 CopLINE_set(PL_curcop, PL_parser->copline);
1683             }
1684             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1685             CopLINE_set(PL_curcop, oldline);
1686         }
1687     }
1688     return scalar(o);
1689 }
1690
1691 static SV *
1692 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1693 {
1694     assert(o);
1695     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1696            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1697     {
1698         const char funny  = o->op_type == OP_PADAV
1699                          || o->op_type == OP_RV2AV ? '@' : '%';
1700         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1701             GV *gv;
1702             if (cUNOPo->op_first->op_type != OP_GV
1703              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1704                 return NULL;
1705             return varname(gv, funny, 0, NULL, 0, subscript_type);
1706         }
1707         return
1708             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1709     }
1710 }
1711
1712 static SV *
1713 S_op_varname(pTHX_ const OP *o)
1714 {
1715     return S_op_varname_subscript(aTHX_ o, 1);
1716 }
1717
1718 static void
1719 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1720 { /* or not so pretty :-) */
1721     if (o->op_type == OP_CONST) {
1722         *retsv = cSVOPo_sv;
1723         if (SvPOK(*retsv)) {
1724             SV *sv = *retsv;
1725             *retsv = sv_newmortal();
1726             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1727                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1728         }
1729         else if (!SvOK(*retsv))
1730             *retpv = "undef";
1731     }
1732     else *retpv = "...";
1733 }
1734
1735 static void
1736 S_scalar_slice_warning(pTHX_ const OP *o)
1737 {
1738     OP *kid;
1739     const bool h = o->op_type == OP_HSLICE
1740                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1741     const char lbrack =
1742         h ? '{' : '[';
1743     const char rbrack =
1744         h ? '}' : ']';
1745     SV *name;
1746     SV *keysv = NULL; /* just to silence compiler warnings */
1747     const char *key = NULL;
1748
1749     if (!(o->op_private & OPpSLICEWARNING))
1750         return;
1751     if (PL_parser && PL_parser->error_count)
1752         /* This warning can be nonsensical when there is a syntax error. */
1753         return;
1754
1755     kid = cLISTOPo->op_first;
1756     kid = OpSIBLING(kid); /* get past pushmark */
1757     /* weed out false positives: any ops that can return lists */
1758     switch (kid->op_type) {
1759     case OP_BACKTICK:
1760     case OP_GLOB:
1761     case OP_READLINE:
1762     case OP_MATCH:
1763     case OP_RV2AV:
1764     case OP_EACH:
1765     case OP_VALUES:
1766     case OP_KEYS:
1767     case OP_SPLIT:
1768     case OP_LIST:
1769     case OP_SORT:
1770     case OP_REVERSE:
1771     case OP_ENTERSUB:
1772     case OP_CALLER:
1773     case OP_LSTAT:
1774     case OP_STAT:
1775     case OP_READDIR:
1776     case OP_SYSTEM:
1777     case OP_TMS:
1778     case OP_LOCALTIME:
1779     case OP_GMTIME:
1780     case OP_ENTEREVAL:
1781         return;
1782     }
1783
1784     /* Don't warn if we have a nulled list either. */
1785     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1786         return;
1787
1788     assert(OpSIBLING(kid));
1789     name = S_op_varname(aTHX_ OpSIBLING(kid));
1790     if (!name) /* XS module fiddling with the op tree */
1791         return;
1792     S_op_pretty(aTHX_ kid, &keysv, &key);
1793     assert(SvPOK(name));
1794     sv_chop(name,SvPVX(name)+1);
1795     if (key)
1796        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1797         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1798                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1799                    "%c%s%c",
1800                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1801                     lbrack, key, rbrack);
1802     else
1803        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1804         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1805                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1806                     SVf "%c%" SVf "%c",
1807                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1808                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1809 }
1810
1811
1812
1813 /* apply scalar context to the o subtree */
1814
1815 OP *
1816 Perl_scalar(pTHX_ OP *o)
1817 {
1818     OP * top_op = o;
1819
1820     while (1) {
1821         OP *next_kid = NULL; /* what op (if any) to process next */
1822         OP *kid;
1823
1824         /* assumes no premature commitment */
1825         if (!o || (PL_parser && PL_parser->error_count)
1826              || (o->op_flags & OPf_WANT)
1827              || o->op_type == OP_RETURN)
1828         {
1829             goto do_next;
1830         }
1831
1832         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1833
1834         switch (o->op_type) {
1835         case OP_REPEAT:
1836             scalar(cBINOPo->op_first);
1837             /* convert what initially looked like a list repeat into a
1838              * scalar repeat, e.g. $s = (1) x $n
1839              */
1840             if (o->op_private & OPpREPEAT_DOLIST) {
1841                 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1842                 assert(kid->op_type == OP_PUSHMARK);
1843                 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1844                     op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1845                     o->op_private &=~ OPpREPEAT_DOLIST;
1846                 }
1847             }
1848             break;
1849
1850         case OP_OR:
1851         case OP_AND:
1852         case OP_COND_EXPR:
1853             /* impose scalar context on everything except the condition */
1854             next_kid = OpSIBLING(cUNOPo->op_first);
1855             break;
1856
1857         default:
1858             if (o->op_flags & OPf_KIDS)
1859                 next_kid = cUNOPo->op_first; /* do all kids */
1860             break;
1861
1862         /* the children of these ops are usually a list of statements,
1863          * except the leaves, whose first child is a corresponding enter
1864          */
1865         case OP_SCOPE:
1866         case OP_LINESEQ:
1867         case OP_LIST:
1868             kid = cLISTOPo->op_first;
1869             goto do_kids;
1870         case OP_LEAVE:
1871         case OP_LEAVETRY:
1872             kid = cLISTOPo->op_first;
1873             scalar(kid);
1874             kid = OpSIBLING(kid);
1875         do_kids:
1876             while (kid) {
1877                 OP *sib = OpSIBLING(kid);
1878                 /* Apply void context to all kids except the last, which
1879                  * is scalar (ignoring a trailing ex-nextstate in determining
1880                  * if it's the last kid). E.g.
1881                  *      $scalar = do { void; void; scalar }
1882                  * Except that 'when's are always scalar, e.g.
1883                  *      $scalar = do { given(..) {
1884                     *                 when (..) { scalar }
1885                     *                 when (..) { scalar }
1886                     *                 ...
1887                     *                }}
1888                     */
1889                 if (!sib
1890                      || (  !OpHAS_SIBLING(sib)
1891                          && sib->op_type == OP_NULL
1892                          && (   sib->op_targ == OP_NEXTSTATE
1893                              || sib->op_targ == OP_DBSTATE  )
1894                         )
1895                 )
1896                 {
1897                     /* tail call optimise calling scalar() on the last kid */
1898                     next_kid = kid;
1899                     goto do_next;
1900                 }
1901                 else if (kid->op_type == OP_LEAVEWHEN)
1902                     scalar(kid);
1903                 else
1904                     scalarvoid(kid);
1905                 kid = sib;
1906             }
1907             NOT_REACHED; /* NOTREACHED */
1908             break;
1909
1910         case OP_SORT:
1911             Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1912             break;
1913
1914         case OP_KVHSLICE:
1915         case OP_KVASLICE:
1916         {
1917             /* Warn about scalar context */
1918             const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1919             const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1920             SV *name;
1921             SV *keysv;
1922             const char *key = NULL;
1923
1924             /* This warning can be nonsensical when there is a syntax error. */
1925             if (PL_parser && PL_parser->error_count)
1926                 break;
1927
1928             if (!ckWARN(WARN_SYNTAX)) break;
1929
1930             kid = cLISTOPo->op_first;
1931             kid = OpSIBLING(kid); /* get past pushmark */
1932             assert(OpSIBLING(kid));
1933             name = S_op_varname(aTHX_ OpSIBLING(kid));
1934             if (!name) /* XS module fiddling with the op tree */
1935                 break;
1936             S_op_pretty(aTHX_ kid, &keysv, &key);
1937             assert(SvPOK(name));
1938             sv_chop(name,SvPVX(name)+1);
1939             if (key)
1940       /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1941                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1942                            "%%%" SVf "%c%s%c in scalar context better written "
1943                            "as $%" SVf "%c%s%c",
1944                             SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1945                             lbrack, key, rbrack);
1946             else
1947       /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1948                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1949                            "%%%" SVf "%c%" SVf "%c in scalar context better "
1950                            "written as $%" SVf "%c%" SVf "%c",
1951                             SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1952                             SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1953         }
1954         } /* switch */
1955
1956         /* If next_kid is set, someone in the code above wanted us to process
1957          * that kid and all its remaining siblings.  Otherwise, work our way
1958          * back up the tree */
1959       do_next:
1960         while (!next_kid) {
1961             if (o == top_op)
1962                 return top_op; /* at top; no parents/siblings to try */
1963             if (OpHAS_SIBLING(o))
1964                 next_kid = o->op_sibparent;
1965             else {
1966                 o = o->op_sibparent; /*try parent's next sibling */
1967                 switch (o->op_type) {
1968                 case OP_SCOPE:
1969                 case OP_LINESEQ:
1970                 case OP_LIST:
1971                 case OP_LEAVE:
1972                 case OP_LEAVETRY:
1973                     /* should really restore PL_curcop to its old value, but
1974                      * setting it to PL_compiling is better than do nothing */
1975                     PL_curcop = &PL_compiling;
1976                 }
1977             }
1978         }
1979         o = next_kid;
1980     } /* while */
1981 }
1982
1983
1984 /* apply void context to the optree arg */
1985
1986 OP *
1987 Perl_scalarvoid(pTHX_ OP *arg)
1988 {
1989     dVAR;
1990     OP *kid;
1991     SV* sv;
1992     OP *o = arg;
1993
1994     PERL_ARGS_ASSERT_SCALARVOID;
1995
1996     while (1) {
1997         U8 want;
1998         SV *useless_sv = NULL;
1999         const char* useless = NULL;
2000         OP * next_kid = NULL;
2001
2002         if (o->op_type == OP_NEXTSTATE
2003             || o->op_type == OP_DBSTATE
2004             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2005                                           || o->op_targ == OP_DBSTATE)))
2006             PL_curcop = (COP*)o;                /* for warning below */
2007
2008         /* assumes no premature commitment */
2009         want = o->op_flags & OPf_WANT;
2010         if ((want && want != OPf_WANT_SCALAR)
2011             || (PL_parser && PL_parser->error_count)
2012             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2013         {
2014             goto get_next_op;
2015         }
2016
2017         if ((o->op_private & OPpTARGET_MY)
2018             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2019         {
2020             /* newASSIGNOP has already applied scalar context, which we
2021                leave, as if this op is inside SASSIGN.  */
2022             goto get_next_op;
2023         }
2024
2025         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2026
2027         switch (o->op_type) {
2028         default:
2029             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2030                 break;
2031             /* FALLTHROUGH */
2032         case OP_REPEAT:
2033             if (o->op_flags & OPf_STACKED)
2034                 break;
2035             if (o->op_type == OP_REPEAT)
2036                 scalar(cBINOPo->op_first);
2037             goto func_ops;
2038         case OP_CONCAT:
2039             if ((o->op_flags & OPf_STACKED) &&
2040                     !(o->op_private & OPpCONCAT_NESTED))
2041                 break;
2042             goto func_ops;
2043         case OP_SUBSTR:
2044             if (o->op_private == 4)
2045                 break;
2046             /* FALLTHROUGH */
2047         case OP_WANTARRAY:
2048         case OP_GV:
2049         case OP_SMARTMATCH:
2050         case OP_AV2ARYLEN:
2051         case OP_REF:
2052         case OP_REFGEN:
2053         case OP_SREFGEN:
2054         case OP_DEFINED:
2055         case OP_HEX:
2056         case OP_OCT:
2057         case OP_LENGTH:
2058         case OP_VEC:
2059         case OP_INDEX:
2060         case OP_RINDEX:
2061         case OP_SPRINTF:
2062         case OP_KVASLICE:
2063         case OP_KVHSLICE:
2064         case OP_UNPACK:
2065         case OP_PACK:
2066         case OP_JOIN:
2067         case OP_LSLICE:
2068         case OP_ANONLIST:
2069         case OP_ANONHASH:
2070         case OP_SORT:
2071         case OP_REVERSE:
2072         case OP_RANGE:
2073         case OP_FLIP:
2074         case OP_FLOP:
2075         case OP_CALLER:
2076         case OP_FILENO:
2077         case OP_EOF:
2078         case OP_TELL:
2079         case OP_GETSOCKNAME:
2080         case OP_GETPEERNAME:
2081         case OP_READLINK:
2082         case OP_TELLDIR:
2083         case OP_GETPPID:
2084         case OP_GETPGRP:
2085         case OP_GETPRIORITY:
2086         case OP_TIME:
2087         case OP_TMS:
2088         case OP_LOCALTIME:
2089         case OP_GMTIME:
2090         case OP_GHBYNAME:
2091         case OP_GHBYADDR:
2092         case OP_GHOSTENT:
2093         case OP_GNBYNAME:
2094         case OP_GNBYADDR:
2095         case OP_GNETENT:
2096         case OP_GPBYNAME:
2097         case OP_GPBYNUMBER:
2098         case OP_GPROTOENT:
2099         case OP_GSBYNAME:
2100         case OP_GSBYPORT:
2101         case OP_GSERVENT:
2102         case OP_GPWNAM:
2103         case OP_GPWUID:
2104         case OP_GGRNAM:
2105         case OP_GGRGID:
2106         case OP_GETLOGIN:
2107         case OP_PROTOTYPE:
2108         case OP_RUNCV:
2109         func_ops:
2110             useless = OP_DESC(o);
2111             break;
2112
2113         case OP_GVSV:
2114         case OP_PADSV:
2115         case OP_PADAV:
2116         case OP_PADHV:
2117         case OP_PADANY:
2118         case OP_AELEM:
2119         case OP_AELEMFAST:
2120         case OP_AELEMFAST_LEX:
2121         case OP_ASLICE:
2122         case OP_HELEM:
2123         case OP_HSLICE:
2124             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2125                 /* Otherwise it's "Useless use of grep iterator" */
2126                 useless = OP_DESC(o);
2127             break;
2128
2129         case OP_SPLIT:
2130             if (!(o->op_private & OPpSPLIT_ASSIGN))
2131                 useless = OP_DESC(o);
2132             break;
2133
2134         case OP_NOT:
2135             kid = cUNOPo->op_first;
2136             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2137                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2138                 goto func_ops;
2139             }
2140             useless = "negative pattern binding (!~)";
2141             break;
2142
2143         case OP_SUBST:
2144             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2145                 useless = "non-destructive substitution (s///r)";
2146             break;
2147
2148         case OP_TRANSR:
2149             useless = "non-destructive transliteration (tr///r)";
2150             break;
2151
2152         case OP_RV2GV:
2153         case OP_RV2SV:
2154         case OP_RV2AV:
2155         case OP_RV2HV:
2156             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2157                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2158                 useless = "a variable";
2159             break;
2160
2161         case OP_CONST:
2162             sv = cSVOPo_sv;
2163             if (cSVOPo->op_private & OPpCONST_STRICT)
2164                 no_bareword_allowed(o);
2165             else {
2166                 if (ckWARN(WARN_VOID)) {
2167                     NV nv;
2168                     /* don't warn on optimised away booleans, eg
2169                      * use constant Foo, 5; Foo || print; */
2170                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2171                         useless = NULL;
2172                     /* the constants 0 and 1 are permitted as they are
2173                        conventionally used as dummies in constructs like
2174                        1 while some_condition_with_side_effects;  */
2175                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2176                         useless = NULL;
2177                     else if (SvPOK(sv)) {
2178                         SV * const dsv = newSVpvs("");
2179                         useless_sv
2180                             = Perl_newSVpvf(aTHX_
2181                                             "a constant (%s)",
2182                                             pv_pretty(dsv, SvPVX_const(sv),
2183                                                       SvCUR(sv), 32, NULL, NULL,
2184                                                       PERL_PV_PRETTY_DUMP
2185                                                       | PERL_PV_ESCAPE_NOCLEAR
2186                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2187                         SvREFCNT_dec_NN(dsv);
2188                     }
2189                     else if (SvOK(sv)) {
2190                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2191                     }
2192                     else
2193                         useless = "a constant (undef)";
2194                 }
2195             }
2196             op_null(o);         /* don't execute or even remember it */
2197             break;
2198
2199         case OP_POSTINC:
2200             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2201             break;
2202
2203         case OP_POSTDEC:
2204             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2205             break;
2206
2207         case OP_I_POSTINC:
2208             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2209             break;
2210
2211         case OP_I_POSTDEC:
2212             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2213             break;
2214
2215         case OP_SASSIGN: {
2216             OP *rv2gv;
2217             UNOP *refgen, *rv2cv;
2218             LISTOP *exlist;
2219
2220             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2221                 break;
2222
2223             rv2gv = ((BINOP *)o)->op_last;
2224             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2225                 break;
2226
2227             refgen = (UNOP *)((BINOP *)o)->op_first;
2228
2229             if (!refgen || (refgen->op_type != OP_REFGEN
2230                             && refgen->op_type != OP_SREFGEN))
2231                 break;
2232
2233             exlist = (LISTOP *)refgen->op_first;
2234             if (!exlist || exlist->op_type != OP_NULL
2235                 || exlist->op_targ != OP_LIST)
2236                 break;
2237
2238             if (exlist->op_first->op_type != OP_PUSHMARK
2239                 && exlist->op_first != exlist->op_last)
2240                 break;
2241
2242             rv2cv = (UNOP*)exlist->op_last;
2243
2244             if (rv2cv->op_type != OP_RV2CV)
2245                 break;
2246
2247             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2248             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2249             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2250
2251             o->op_private |= OPpASSIGN_CV_TO_GV;
2252             rv2gv->op_private |= OPpDONT_INIT_GV;
2253             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2254
2255             break;
2256         }
2257
2258         case OP_AASSIGN: {
2259             inplace_aassign(o);
2260             break;
2261         }
2262
2263         case OP_OR:
2264         case OP_AND:
2265             kid = cLOGOPo->op_first;
2266             if (kid->op_type == OP_NOT
2267                 && (kid->op_flags & OPf_KIDS)) {
2268                 if (o->op_type == OP_AND) {
2269                     OpTYPE_set(o, OP_OR);
2270                 } else {
2271                     OpTYPE_set(o, OP_AND);
2272                 }
2273                 op_null(kid);
2274             }
2275             /* FALLTHROUGH */
2276
2277         case OP_DOR:
2278         case OP_COND_EXPR:
2279         case OP_ENTERGIVEN:
2280         case OP_ENTERWHEN:
2281             next_kid = OpSIBLING(cUNOPo->op_first);
2282         break;
2283
2284         case OP_NULL:
2285             if (o->op_flags & OPf_STACKED)
2286                 break;
2287             /* FALLTHROUGH */
2288         case OP_NEXTSTATE:
2289         case OP_DBSTATE:
2290         case OP_ENTERTRY:
2291         case OP_ENTER:
2292             if (!(o->op_flags & OPf_KIDS))
2293                 break;
2294             /* FALLTHROUGH */
2295         case OP_SCOPE:
2296         case OP_LEAVE:
2297         case OP_LEAVETRY:
2298         case OP_LEAVELOOP:
2299         case OP_LINESEQ:
2300         case OP_LEAVEGIVEN:
2301         case OP_LEAVEWHEN:
2302         kids:
2303             next_kid = cLISTOPo->op_first;
2304             break;
2305         case OP_LIST:
2306             /* If the first kid after pushmark is something that the padrange
2307                optimisation would reject, then null the list and the pushmark.
2308             */
2309             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2310                 && (  !(kid = OpSIBLING(kid))
2311                       || (  kid->op_type != OP_PADSV
2312                             && kid->op_type != OP_PADAV
2313                             && kid->op_type != OP_PADHV)
2314                       || kid->op_private & ~OPpLVAL_INTRO
2315                       || !(kid = OpSIBLING(kid))
2316                       || (  kid->op_type != OP_PADSV
2317                             && kid->op_type != OP_PADAV
2318                             && kid->op_type != OP_PADHV)
2319                       || kid->op_private & ~OPpLVAL_INTRO)
2320             ) {
2321                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2322                 op_null(o); /* NULL the list */
2323             }
2324             goto kids;
2325         case OP_ENTEREVAL:
2326             scalarkids(o);
2327             break;
2328         case OP_SCALAR:
2329             scalar(o);
2330             break;
2331         }
2332
2333         if (useless_sv) {
2334             /* mortalise it, in case warnings are fatal.  */
2335             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2336                            "Useless use of %" SVf " in void context",
2337                            SVfARG(sv_2mortal(useless_sv)));
2338         }
2339         else if (useless) {
2340             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2341                            "Useless use of %s in void context",
2342                            useless);
2343         }
2344
2345       get_next_op:
2346         /* if a kid hasn't been nominated to process, continue with the
2347          * next sibling, or if no siblings left, go back to the parent's
2348          * siblings and so on
2349          */
2350         while (!next_kid) {
2351             if (o == arg)
2352                 return arg; /* at top; no parents/siblings to try */
2353             if (OpHAS_SIBLING(o))
2354                 next_kid = o->op_sibparent;
2355             else
2356                 o = o->op_sibparent; /*try parent's next sibling */
2357         }
2358         o = next_kid;
2359     }
2360
2361     return arg;
2362 }
2363
2364
2365 static OP *
2366 S_listkids(pTHX_ OP *o)
2367 {
2368     if (o && o->op_flags & OPf_KIDS) {
2369         OP *kid;
2370         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2371             list(kid);
2372     }
2373     return o;
2374 }
2375
2376
2377 /* apply list context to the o subtree */
2378
2379 OP *
2380 Perl_list(pTHX_ OP *o)
2381 {
2382     OP * top_op = o;
2383
2384     while (1) {
2385         OP *next_kid = NULL; /* what op (if any) to process next */
2386
2387         OP *kid;
2388
2389         /* assumes no premature commitment */
2390         if (!o || (o->op_flags & OPf_WANT)
2391              || (PL_parser && PL_parser->error_count)
2392              || o->op_type == OP_RETURN)
2393         {
2394             goto do_next;
2395         }
2396
2397         if ((o->op_private & OPpTARGET_MY)
2398             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2399         {
2400             goto do_next;                               /* As if inside SASSIGN */
2401         }
2402
2403         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2404
2405         switch (o->op_type) {
2406         case OP_REPEAT:
2407             if (o->op_private & OPpREPEAT_DOLIST
2408              && !(o->op_flags & OPf_STACKED))
2409             {
2410                 list(cBINOPo->op_first);
2411                 kid = cBINOPo->op_last;
2412                 /* optimise away (.....) x 1 */
2413                 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2414                  && SvIVX(kSVOP_sv) == 1)
2415                 {
2416                     op_null(o); /* repeat */
2417                     op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2418                     /* const (rhs): */
2419                     op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2420                 }
2421             }
2422             break;
2423
2424         case OP_OR:
2425         case OP_AND:
2426         case OP_COND_EXPR:
2427             /* impose list context on everything except the condition */
2428             next_kid = OpSIBLING(cUNOPo->op_first);
2429             break;
2430
2431         default:
2432             if (!(o->op_flags & OPf_KIDS))
2433                 break;
2434             /* possibly flatten 1..10 into a constant array */
2435             if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2436                 list(cBINOPo->op_first);
2437                 gen_constant_list(o);
2438                 goto do_next;
2439             }
2440             next_kid = cUNOPo->op_first; /* do all kids */
2441             break;
2442
2443         case OP_LIST:
2444             if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2445                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2446                 op_null(o); /* NULL the list */
2447             }
2448             if (o->op_flags & OPf_KIDS)
2449                 next_kid = cUNOPo->op_first; /* do all kids */
2450             break;
2451
2452         /* the children of these ops are usually a list of statements,
2453          * except the leaves, whose first child is a corresponding enter
2454          */
2455         case OP_SCOPE:
2456         case OP_LINESEQ:
2457             kid = cLISTOPo->op_first;
2458             goto do_kids;
2459         case OP_LEAVE:
2460         case OP_LEAVETRY:
2461             kid = cLISTOPo->op_first;
2462             list(kid);
2463             kid = OpSIBLING(kid);
2464         do_kids:
2465             while (kid) {
2466                 OP *sib = OpSIBLING(kid);
2467                 /* Apply void context to all kids except the last, which
2468                  * is list. E.g.
2469                  *      @a = do { void; void; list }
2470                  * Except that 'when's are always list context, e.g.
2471                  *      @a = do { given(..) {
2472                     *                 when (..) { list }
2473                     *                 when (..) { list }
2474                     *                 ...
2475                     *                }}
2476                     */
2477                 if (!sib) {
2478                     /* tail call optimise calling list() on the last kid */
2479                     next_kid = kid;
2480                     goto do_next;
2481                 }
2482                 else if (kid->op_type == OP_LEAVEWHEN)
2483                     list(kid);
2484                 else
2485                     scalarvoid(kid);
2486                 kid = sib;
2487             }
2488             NOT_REACHED; /* NOTREACHED */
2489             break;
2490
2491         }
2492
2493         /* If next_kid is set, someone in the code above wanted us to process
2494          * that kid and all its remaining siblings.  Otherwise, work our way
2495          * back up the tree */
2496       do_next:
2497         while (!next_kid) {
2498             if (o == top_op)
2499                 return top_op; /* at top; no parents/siblings to try */
2500             if (OpHAS_SIBLING(o))
2501                 next_kid = o->op_sibparent;
2502             else {
2503                 o = o->op_sibparent; /*try parent's next sibling */
2504                 switch (o->op_type) {
2505                 case OP_SCOPE:
2506                 case OP_LINESEQ:
2507                 case OP_LIST:
2508                 case OP_LEAVE:
2509                 case OP_LEAVETRY:
2510                     /* should really restore PL_curcop to its old value, but
2511                      * setting it to PL_compiling is better than do nothing */
2512                     PL_curcop = &PL_compiling;
2513                 }
2514             }
2515
2516
2517         }
2518         o = next_kid;
2519     } /* while */
2520 }
2521
2522
2523 static OP *
2524 S_scalarseq(pTHX_ OP *o)
2525 {
2526     if (o) {
2527         const OPCODE type = o->op_type;
2528
2529         if (type == OP_LINESEQ || type == OP_SCOPE ||
2530             type == OP_LEAVE || type == OP_LEAVETRY)
2531         {
2532             OP *kid, *sib;
2533             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2534                 if ((sib = OpSIBLING(kid))
2535                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2536                     || (  sib->op_targ != OP_NEXTSTATE
2537                        && sib->op_targ != OP_DBSTATE  )))
2538                 {
2539                     scalarvoid(kid);
2540                 }
2541             }
2542             PL_curcop = &PL_compiling;
2543         }
2544         o->op_flags &= ~OPf_PARENS;
2545         if (PL_hints & HINT_BLOCK_SCOPE)
2546             o->op_flags |= OPf_PARENS;
2547     }
2548     else
2549         o = newOP(OP_STUB, 0);
2550     return o;
2551 }
2552
2553 STATIC OP *
2554 S_modkids(pTHX_ OP *o, I32 type)
2555 {
2556     if (o && o->op_flags & OPf_KIDS) {
2557         OP *kid;
2558         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2559             op_lvalue(kid, type);
2560     }
2561     return o;
2562 }
2563
2564
2565 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2566  * const fields. Also, convert CONST keys to HEK-in-SVs.
2567  * rop    is the op that retrieves the hash;
2568  * key_op is the first key
2569  * real   if false, only check (and possibly croak); don't update op
2570  */
2571
2572 STATIC void
2573 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2574 {
2575     PADNAME *lexname;
2576     GV **fields;
2577     bool check_fields;
2578
2579     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2580     if (rop) {
2581         if (rop->op_first->op_type == OP_PADSV)
2582             /* @$hash{qw(keys here)} */
2583             rop = (UNOP*)rop->op_first;
2584         else {
2585             /* @{$hash}{qw(keys here)} */
2586             if (rop->op_first->op_type == OP_SCOPE
2587                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2588                 {
2589                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2590                 }
2591             else
2592                 rop = NULL;
2593         }
2594     }
2595
2596     lexname = NULL; /* just to silence compiler warnings */
2597     fields  = NULL; /* just to silence compiler warnings */
2598
2599     check_fields =
2600             rop
2601          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2602              SvPAD_TYPED(lexname))
2603          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2604          && isGV(*fields) && GvHV(*fields);
2605
2606     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2607         SV **svp, *sv;
2608         if (key_op->op_type != OP_CONST)
2609             continue;
2610         svp = cSVOPx_svp(key_op);
2611
2612         /* make sure it's not a bareword under strict subs */
2613         if (key_op->op_private & OPpCONST_BARE &&
2614             key_op->op_private & OPpCONST_STRICT)
2615         {
2616             no_bareword_allowed((OP*)key_op);
2617         }
2618
2619         /* Make the CONST have a shared SV */
2620         if (   !SvIsCOW_shared_hash(sv = *svp)
2621             && SvTYPE(sv) < SVt_PVMG
2622             && SvOK(sv)
2623             && !SvROK(sv)
2624             && real)
2625         {
2626             SSize_t keylen;
2627             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2628             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2629             SvREFCNT_dec_NN(sv);
2630             *svp = nsv;
2631         }
2632
2633         if (   check_fields
2634             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2635         {
2636             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2637                         "in variable %" PNf " of type %" HEKf,
2638                         SVfARG(*svp), PNfARG(lexname),
2639                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2640         }
2641     }
2642 }
2643
2644 /* info returned by S_sprintf_is_multiconcatable() */
2645
2646 struct sprintf_ismc_info {
2647     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2648     char  *start;     /* start of raw format string */
2649     char  *end;       /* bytes after end of raw format string */
2650     STRLEN total_len; /* total length (in bytes) of format string, not
2651                          including '%s' and  half of '%%' */
2652     STRLEN variant;   /* number of bytes by which total_len_p would grow
2653                          if upgraded to utf8 */
2654     bool   utf8;      /* whether the format is utf8 */
2655 };
2656
2657
2658 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2659  * i.e. its format argument is a const string with only '%s' and '%%'
2660  * formats, and the number of args is known, e.g.
2661  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2662  * but not
2663  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2664  *
2665  * If successful, the sprintf_ismc_info struct pointed to by info will be
2666  * populated.
2667  */
2668
2669 STATIC bool
2670 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2671 {
2672     OP    *pm, *constop, *kid;
2673     SV    *sv;
2674     char  *s, *e, *p;
2675     SSize_t nargs, nformats;
2676     STRLEN cur, total_len, variant;
2677     bool   utf8;
2678
2679     /* if sprintf's behaviour changes, die here so that someone
2680      * can decide whether to enhance this function or skip optimising
2681      * under those new circumstances */
2682     assert(!(o->op_flags & OPf_STACKED));
2683     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2684     assert(!(o->op_private & ~OPpARG4_MASK));
2685
2686     pm = cUNOPo->op_first;
2687     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2688         return FALSE;
2689     constop = OpSIBLING(pm);
2690     if (!constop || constop->op_type != OP_CONST)
2691         return FALSE;
2692     sv = cSVOPx_sv(constop);
2693     if (SvMAGICAL(sv) || !SvPOK(sv))
2694         return FALSE;
2695
2696     s = SvPV(sv, cur);
2697     e = s + cur;
2698
2699     /* Scan format for %% and %s and work out how many %s there are.
2700      * Abandon if other format types are found.
2701      */
2702
2703     nformats  = 0;
2704     total_len = 0;
2705     variant   = 0;
2706
2707     for (p = s; p < e; p++) {
2708         if (*p != '%') {
2709             total_len++;
2710             if (!UTF8_IS_INVARIANT(*p))
2711                 variant++;
2712             continue;
2713         }
2714         p++;
2715         if (p >= e)
2716             return FALSE; /* lone % at end gives "Invalid conversion" */
2717         if (*p == '%')
2718             total_len++;
2719         else if (*p == 's')
2720             nformats++;
2721         else
2722             return FALSE;
2723     }
2724
2725     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2726         return FALSE;
2727
2728     utf8 = cBOOL(SvUTF8(sv));
2729     if (utf8)
2730         variant = 0;
2731
2732     /* scan args; they must all be in scalar cxt */
2733
2734     nargs = 0;
2735     kid = OpSIBLING(constop);
2736
2737     while (kid) {
2738         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2739             return FALSE;
2740         nargs++;
2741         kid = OpSIBLING(kid);
2742     }
2743
2744     if (nargs != nformats)
2745         return FALSE; /* e.g. sprintf("%s%s", $a); */
2746
2747
2748     info->nargs      = nargs;
2749     info->start      = s;
2750     info->end        = e;
2751     info->total_len  = total_len;
2752     info->variant    = variant;
2753     info->utf8       = utf8;
2754
2755     return TRUE;
2756 }
2757
2758
2759
2760 /* S_maybe_multiconcat():
2761  *
2762  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2763  * convert it (and its children) into an OP_MULTICONCAT. See the code
2764  * comments just before pp_multiconcat() for the full details of what
2765  * OP_MULTICONCAT supports.
2766  *
2767  * Basically we're looking for an optree with a chain of OP_CONCATS down
2768  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2769  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2770  *
2771  *      $x = "$a$b-$c"
2772  *
2773  *  looks like
2774  *
2775  *      SASSIGN
2776  *         |
2777  *      STRINGIFY   -- PADSV[$x]
2778  *         |
2779  *         |
2780  *      ex-PUSHMARK -- CONCAT/S
2781  *                        |
2782  *                     CONCAT/S  -- PADSV[$d]
2783  *                        |
2784  *                     CONCAT    -- CONST["-"]
2785  *                        |
2786  *                     PADSV[$a] -- PADSV[$b]
2787  *
2788  * Note that at this stage the OP_SASSIGN may have already been optimised
2789  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2790  */
2791
2792 STATIC void
2793 S_maybe_multiconcat(pTHX_ OP *o)
2794 {
2795     dVAR;
2796     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2797     OP *topop;       /* the top-most op in the concat tree (often equals o,
2798                         unless there are assign/stringify ops above it */
2799     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2800     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2801     OP *targetop;    /* the op corresponding to target=... or target.=... */
2802     OP *stringop;    /* the OP_STRINGIFY op, if any */
2803     OP *nextop;      /* used for recreating the op_next chain without consts */
2804     OP *kid;         /* general-purpose op pointer */
2805     UNOP_AUX_item *aux;
2806     UNOP_AUX_item *lenp;
2807     char *const_str, *p;
2808     struct sprintf_ismc_info sprintf_info;
2809
2810                      /* store info about each arg in args[];
2811                       * toparg is the highest used slot; argp is a general
2812                       * pointer to args[] slots */
2813     struct {
2814         void *p;      /* initially points to const sv (or null for op);
2815                          later, set to SvPV(constsv), with ... */
2816         STRLEN len;   /* ... len set to SvPV(..., len) */
2817     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2818
2819     SSize_t nargs  = 0;
2820     SSize_t nconst = 0;
2821     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2822     STRLEN variant;
2823     bool utf8 = FALSE;
2824     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2825                                  the last-processed arg will the LHS of one,
2826                                  as args are processed in reverse order */
2827     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2828     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2829     U8 flags          = 0;   /* what will become the op_flags and ... */
2830     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2831     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2832     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2833     bool prev_was_const = FALSE; /* previous arg was a const */
2834
2835     /* -----------------------------------------------------------------
2836      * Phase 1:
2837      *
2838      * Examine the optree non-destructively to determine whether it's
2839      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2840      * information about the optree in args[].
2841      */
2842
2843     argp     = args;
2844     targmyop = NULL;
2845     targetop = NULL;
2846     stringop = NULL;
2847     topop    = o;
2848     parentop = o;
2849
2850     assert(   o->op_type == OP_SASSIGN
2851            || o->op_type == OP_CONCAT
2852            || o->op_type == OP_SPRINTF
2853            || o->op_type == OP_STRINGIFY);
2854
2855     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2856
2857     /* first see if, at the top of the tree, there is an assign,
2858      * append and/or stringify */
2859
2860     if (topop->op_type == OP_SASSIGN) {
2861         /* expr = ..... */
2862         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2863             return;
2864         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2865             return;
2866         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2867
2868         parentop = topop;
2869         topop = cBINOPo->op_first;
2870         targetop = OpSIBLING(topop);
2871         if (!targetop) /* probably some sort of syntax error */
2872             return;
2873     }
2874     else if (   topop->op_type == OP_CONCAT
2875              && (topop->op_flags & OPf_STACKED)
2876              && (!(topop->op_private & OPpCONCAT_NESTED))
2877             )
2878     {
2879         /* expr .= ..... */
2880
2881         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2882          * decide what to do about it */
2883         assert(!(o->op_private & OPpTARGET_MY));
2884
2885         /* barf on unknown flags */
2886         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2887         private_flags |= OPpMULTICONCAT_APPEND;
2888         targetop = cBINOPo->op_first;
2889         parentop = topop;
2890         topop    = OpSIBLING(targetop);
2891
2892         /* $x .= <FOO> gets optimised to rcatline instead */
2893         if (topop->op_type == OP_READLINE)
2894             return;
2895     }
2896
2897     if (targetop) {
2898         /* Can targetop (the LHS) if it's a padsv, be be optimised
2899          * away and use OPpTARGET_MY instead?
2900          */
2901         if (    (targetop->op_type == OP_PADSV)
2902             && !(targetop->op_private & OPpDEREF)
2903             && !(targetop->op_private & OPpPAD_STATE)
2904                /* we don't support 'my $x .= ...' */
2905             && (   o->op_type == OP_SASSIGN
2906                 || !(targetop->op_private & OPpLVAL_INTRO))
2907         )
2908             is_targable = TRUE;
2909     }
2910
2911     if (topop->op_type == OP_STRINGIFY) {
2912         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2913             return;
2914         stringop = topop;
2915
2916         /* barf on unknown flags */
2917         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2918
2919         if ((topop->op_private & OPpTARGET_MY)) {
2920             if (o->op_type == OP_SASSIGN)
2921                 return; /* can't have two assigns */
2922             targmyop = topop;
2923         }
2924
2925         private_flags |= OPpMULTICONCAT_STRINGIFY;
2926         parentop = topop;
2927         topop = cBINOPx(topop)->op_first;
2928         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2929         topop = OpSIBLING(topop);
2930     }
2931
2932     if (topop->op_type == OP_SPRINTF) {
2933         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2934             return;
2935         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2936             nargs     = sprintf_info.nargs;
2937             total_len = sprintf_info.total_len;
2938             variant   = sprintf_info.variant;
2939             utf8      = sprintf_info.utf8;
2940             is_sprintf = TRUE;
2941             private_flags |= OPpMULTICONCAT_FAKE;
2942             toparg = argp;
2943             /* we have an sprintf op rather than a concat optree.
2944              * Skip most of the code below which is associated with
2945              * processing that optree. We also skip phase 2, determining
2946              * whether its cost effective to optimise, since for sprintf,
2947              * multiconcat is *always* faster */
2948             goto create_aux;
2949         }
2950         /* note that even if the sprintf itself isn't multiconcatable,
2951          * the expression as a whole may be, e.g. in
2952          *    $x .= sprintf("%d",...)
2953          * the sprintf op will be left as-is, but the concat/S op may
2954          * be upgraded to multiconcat
2955          */
2956     }
2957     else if (topop->op_type == OP_CONCAT) {
2958         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2959             return;
2960
2961         if ((topop->op_private & OPpTARGET_MY)) {
2962             if (o->op_type == OP_SASSIGN || targmyop)
2963                 return; /* can't have two assigns */
2964             targmyop = topop;
2965         }
2966     }
2967
2968     /* Is it safe to convert a sassign/stringify/concat op into
2969      * a multiconcat? */
2970     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2971     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2972     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2973     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2974     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2975                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2976     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2977                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2978
2979     /* Now scan the down the tree looking for a series of
2980      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2981      * stacked). For example this tree:
2982      *
2983      *     |
2984      *   CONCAT/STACKED
2985      *     |
2986      *   CONCAT/STACKED -- EXPR5
2987      *     |
2988      *   CONCAT/STACKED -- EXPR4
2989      *     |
2990      *   CONCAT -- EXPR3
2991      *     |
2992      *   EXPR1  -- EXPR2
2993      *
2994      * corresponds to an expression like
2995      *
2996      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2997      *
2998      * Record info about each EXPR in args[]: in particular, whether it is
2999      * a stringifiable OP_CONST and if so what the const sv is.
3000      *
3001      * The reason why the last concat can't be STACKED is the difference
3002      * between
3003      *
3004      *    ((($a .= $a) .= $a) .= $a) .= $a
3005      *
3006      * and
3007      *    $a . $a . $a . $a . $a
3008      *
3009      * The main difference between the optrees for those two constructs
3010      * is the presence of the last STACKED. As well as modifying $a,
3011      * the former sees the changed $a between each concat, so if $s is
3012      * initially 'a', the first returns 'a' x 16, while the latter returns
3013      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
3014      */
3015
3016     kid = topop;
3017
3018     for (;;) {
3019         OP *argop;
3020         SV *sv;
3021         bool last = FALSE;
3022
3023         if (    kid->op_type == OP_CONCAT
3024             && !kid_is_last
3025         ) {
3026             OP *k1, *k2;
3027             k1 = cUNOPx(kid)->op_first;
3028             k2 = OpSIBLING(k1);
3029             /* shouldn't happen except maybe after compile err? */
3030             if (!k2)
3031                 return;
3032
3033             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
3034             if (kid->op_private & OPpTARGET_MY)
3035                 kid_is_last = TRUE;
3036
3037             stacked_last = (kid->op_flags & OPf_STACKED);
3038             if (!stacked_last)
3039                 kid_is_last = TRUE;
3040
3041             kid   = k1;
3042             argop = k2;
3043         }
3044         else {
3045             argop = kid;
3046             last = TRUE;
3047         }
3048
3049         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
3050             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3051         {
3052             /* At least two spare slots are needed to decompose both
3053              * concat args. If there are no slots left, continue to
3054              * examine the rest of the optree, but don't push new values
3055              * on args[]. If the optree as a whole is legal for conversion
3056              * (in particular that the last concat isn't STACKED), then
3057              * the first PERL_MULTICONCAT_MAXARG elements of the optree
3058              * can be converted into an OP_MULTICONCAT now, with the first
3059              * child of that op being the remainder of the optree -
3060              * which may itself later be converted to a multiconcat op
3061              * too.
3062              */
3063             if (last) {
3064                 /* the last arg is the rest of the optree */
3065                 argp++->p = NULL;
3066                 nargs++;
3067             }
3068         }
3069         else if (   argop->op_type == OP_CONST
3070             && ((sv = cSVOPx_sv(argop)))
3071             /* defer stringification until runtime of 'constant'
3072              * things that might stringify variantly, e.g. the radix
3073              * point of NVs, or overloaded RVs */
3074             && (SvPOK(sv) || SvIOK(sv))
3075             && (!SvGMAGICAL(sv))
3076         ) {
3077             argp++->p = sv;
3078             utf8   |= cBOOL(SvUTF8(sv));
3079             nconst++;
3080             if (prev_was_const)
3081                 /* this const may be demoted back to a plain arg later;
3082                  * make sure we have enough arg slots left */
3083                 nadjconst++;
3084             prev_was_const = !prev_was_const;
3085         }
3086         else {
3087             argp++->p = NULL;
3088             nargs++;
3089             prev_was_const = FALSE;
3090         }
3091
3092         if (last)
3093             break;
3094     }
3095
3096     toparg = argp - 1;
3097
3098     if (stacked_last)
3099         return; /* we don't support ((A.=B).=C)...) */
3100
3101     /* look for two adjacent consts and don't fold them together:
3102      *     $o . "a" . "b"
3103      * should do
3104      *     $o->concat("a")->concat("b")
3105      * rather than
3106      *     $o->concat("ab")
3107      * (but $o .=  "a" . "b" should still fold)
3108      */
3109     {
3110         bool seen_nonconst = FALSE;
3111         for (argp = toparg; argp >= args; argp--) {
3112             if (argp->p == NULL) {
3113                 seen_nonconst = TRUE;
3114                 continue;
3115             }
3116             if (!seen_nonconst)
3117                 continue;
3118             if (argp[1].p) {
3119                 /* both previous and current arg were constants;
3120                  * leave the current OP_CONST as-is */
3121                 argp->p = NULL;
3122                 nconst--;
3123                 nargs++;
3124             }
3125         }
3126     }
3127
3128     /* -----------------------------------------------------------------
3129      * Phase 2:
3130      *
3131      * At this point we have determined that the optree *can* be converted
3132      * into a multiconcat. Having gathered all the evidence, we now decide
3133      * whether it *should*.
3134      */
3135
3136
3137     /* we need at least one concat action, e.g.:
3138      *
3139      *  Y . Z
3140      *  X = Y . Z
3141      *  X .= Y
3142      *
3143      * otherwise we could be doing something like $x = "foo", which
3144      * if treated as as a concat, would fail to COW.
3145      */
3146     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3147         return;
3148
3149     /* Benchmarking seems to indicate that we gain if:
3150      * * we optimise at least two actions into a single multiconcat
3151      *    (e.g concat+concat, sassign+concat);
3152      * * or if we can eliminate at least 1 OP_CONST;
3153      * * or if we can eliminate a padsv via OPpTARGET_MY
3154      */
3155
3156     if (
3157            /* eliminated at least one OP_CONST */
3158            nconst >= 1
3159            /* eliminated an OP_SASSIGN */
3160         || o->op_type == OP_SASSIGN
3161            /* eliminated an OP_PADSV */
3162         || (!targmyop && is_targable)
3163     )
3164         /* definitely a net gain to optimise */
3165         goto optimise;
3166
3167     /* ... if not, what else? */
3168
3169     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3170      * multiconcat is faster (due to not creating a temporary copy of
3171      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3172      * faster.
3173      */
3174     if (   nconst == 0
3175          && nargs == 2
3176          && targmyop
3177          && topop->op_type == OP_CONCAT
3178     ) {
3179         PADOFFSET t = targmyop->op_targ;
3180         OP *k1 = cBINOPx(topop)->op_first;
3181         OP *k2 = cBINOPx(topop)->op_last;
3182         if (   k2->op_type == OP_PADSV
3183             && k2->op_targ == t
3184             && (   k1->op_type != OP_PADSV
3185                 || k1->op_targ != t)
3186         )
3187             goto optimise;
3188     }
3189
3190     /* need at least two concats */
3191     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3192         return;
3193
3194
3195
3196     /* -----------------------------------------------------------------
3197      * Phase 3:
3198      *
3199      * At this point the optree has been verified as ok to be optimised
3200      * into an OP_MULTICONCAT. Now start changing things.
3201      */
3202
3203    optimise:
3204
3205     /* stringify all const args and determine utf8ness */
3206
3207     variant = 0;
3208     for (argp = args; argp <= toparg; argp++) {
3209         SV *sv = (SV*)argp->p;
3210         if (!sv)
3211             continue; /* not a const op */
3212         if (utf8 && !SvUTF8(sv))
3213             sv_utf8_upgrade_nomg(sv);
3214         argp->p = SvPV_nomg(sv, argp->len);
3215         total_len += argp->len;
3216         
3217         /* see if any strings would grow if converted to utf8 */
3218         if (!utf8) {
3219             variant += variant_under_utf8_count((U8 *) argp->p,
3220                                                 (U8 *) argp->p + argp->len);
3221         }
3222     }
3223
3224     /* create and populate aux struct */
3225
3226   create_aux:
3227
3228     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3229                     sizeof(UNOP_AUX_item)
3230                     *  (
3231                            PERL_MULTICONCAT_HEADER_SIZE
3232                          + ((nargs + 1) * (variant ? 2 : 1))
3233                         )
3234                     );
3235     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3236
3237     /* Extract all the non-const expressions from the concat tree then
3238      * dispose of the old tree, e.g. convert the tree from this:
3239      *
3240      *  o => SASSIGN
3241      *         |
3242      *       STRINGIFY   -- TARGET
3243      *         |
3244      *       ex-PUSHMARK -- CONCAT
3245      *                        |
3246      *                      CONCAT -- EXPR5
3247      *                        |
3248      *                      CONCAT -- EXPR4
3249      *                        |
3250      *                      CONCAT -- EXPR3
3251      *                        |
3252      *                      EXPR1  -- EXPR2
3253      *
3254      *
3255      * to:
3256      *
3257      *  o => MULTICONCAT
3258      *         |
3259      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3260      *
3261      * except that if EXPRi is an OP_CONST, it's discarded.
3262      *
3263      * During the conversion process, EXPR ops are stripped from the tree
3264      * and unshifted onto o. Finally, any of o's remaining original
3265      * childen are discarded and o is converted into an OP_MULTICONCAT.
3266      *
3267      * In this middle of this, o may contain both: unshifted args on the
3268      * left, and some remaining original args on the right. lastkidop
3269      * is set to point to the right-most unshifted arg to delineate
3270      * between the two sets.
3271      */
3272
3273
3274     if (is_sprintf) {
3275         /* create a copy of the format with the %'s removed, and record
3276          * the sizes of the const string segments in the aux struct */
3277         char *q, *oldq;
3278         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3279
3280         p    = sprintf_info.start;
3281         q    = const_str;
3282         oldq = q;
3283         for (; p < sprintf_info.end; p++) {
3284             if (*p == '%') {
3285                 p++;
3286                 if (*p != '%') {
3287                     (lenp++)->ssize = q - oldq;
3288                     oldq = q;
3289                     continue;
3290                 }
3291             }
3292             *q++ = *p;
3293         }
3294         lenp->ssize = q - oldq;
3295         assert((STRLEN)(q - const_str) == total_len);
3296
3297         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3298          * may or may not be topop) The pushmark and const ops need to be
3299          * kept in case they're an op_next entry point.
3300          */
3301         lastkidop = cLISTOPx(topop)->op_last;
3302         kid = cUNOPx(topop)->op_first; /* pushmark */
3303         op_null(kid);
3304         op_null(OpSIBLING(kid));       /* const */
3305         if (o != topop) {
3306             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3307             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3308             lastkidop->op_next = o;
3309         }
3310     }
3311     else {
3312         p = const_str;
3313         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3314
3315         lenp->ssize = -1;
3316
3317         /* Concatenate all const strings into const_str.
3318          * Note that args[] contains the RHS args in reverse order, so
3319          * we scan args[] from top to bottom to get constant strings
3320          * in L-R order
3321          */
3322         for (argp = toparg; argp >= args; argp--) {
3323             if (!argp->p)
3324                 /* not a const op */
3325                 (++lenp)->ssize = -1;
3326             else {
3327                 STRLEN l = argp->len;
3328                 Copy(argp->p, p, l, char);
3329                 p += l;
3330                 if (lenp->ssize == -1)
3331                     lenp->ssize = l;
3332                 else
3333                     lenp->ssize += l;
3334             }
3335         }
3336
3337         kid = topop;
3338         nextop = o;
3339         lastkidop = NULL;
3340
3341         for (argp = args; argp <= toparg; argp++) {
3342             /* only keep non-const args, except keep the first-in-next-chain
3343              * arg no matter what it is (but nulled if OP_CONST), because it
3344              * may be the entry point to this subtree from the previous
3345              * op_next.
3346              */
3347             bool last = (argp == toparg);
3348             OP *prev;
3349
3350             /* set prev to the sibling *before* the arg to be cut out,
3351              * e.g. when cutting EXPR:
3352              *
3353              *         |
3354              * kid=  CONCAT
3355              *         |
3356              * prev= CONCAT -- EXPR
3357              *         |
3358              */
3359             if (argp == args && kid->op_type != OP_CONCAT) {
3360                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3361                  * so the expression to be cut isn't kid->op_last but
3362                  * kid itself */
3363                 OP *o1, *o2;
3364                 /* find the op before kid */
3365                 o1 = NULL;
3366                 o2 = cUNOPx(parentop)->op_first;
3367                 while (o2 && o2 != kid) {
3368                     o1 = o2;
3369                     o2 = OpSIBLING(o2);
3370                 }
3371                 assert(o2 == kid);
3372                 prev = o1;
3373                 kid  = parentop;
3374             }
3375             else if (kid == o && lastkidop)
3376                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3377             else
3378                 prev = last ? NULL : cUNOPx(kid)->op_first;
3379
3380             if (!argp->p || last) {
3381                 /* cut RH op */
3382                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3383                 /* and unshift to front of o */
3384                 op_sibling_splice(o, NULL, 0, aop);
3385                 /* record the right-most op added to o: later we will
3386                  * free anything to the right of it */
3387                 if (!lastkidop)
3388                     lastkidop = aop;
3389                 aop->op_next = nextop;
3390                 if (last) {
3391                     if (argp->p)
3392                         /* null the const at start of op_next chain */
3393                         op_null(aop);
3394                 }
3395                 else if (prev)
3396                     nextop = prev->op_next;
3397             }
3398
3399             /* the last two arguments are both attached to the same concat op */
3400             if (argp < toparg - 1)
3401                 kid = prev;
3402         }
3403     }
3404
3405     /* Populate the aux struct */
3406
3407     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3408     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3409     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3410     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3411     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3412
3413     /* if variant > 0, calculate a variant const string and lengths where
3414      * the utf8 version of the string will take 'variant' more bytes than
3415      * the plain one. */
3416
3417     if (variant) {
3418         char              *p = const_str;
3419         STRLEN          ulen = total_len + variant;
3420         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3421         UNOP_AUX_item *ulens = lens + (nargs + 1);
3422         char             *up = (char*)PerlMemShared_malloc(ulen);
3423         SSize_t            n;
3424
3425         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3426         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3427
3428         for (n = 0; n < (nargs + 1); n++) {
3429             SSize_t i;
3430             char * orig_up = up;
3431             for (i = (lens++)->ssize; i > 0; i--) {
3432                 U8 c = *p++;
3433                 append_utf8_from_native_byte(c, (U8**)&up);
3434             }
3435             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3436         }
3437     }
3438
3439     if (stringop) {
3440         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3441          * that op's first child - an ex-PUSHMARK - because the op_next of
3442          * the previous op may point to it (i.e. it's the entry point for
3443          * the o optree)
3444          */
3445         OP *pmop =
3446             (stringop == o)
3447                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3448                 : op_sibling_splice(stringop, NULL, 1, NULL);
3449         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3450         op_sibling_splice(o, NULL, 0, pmop);
3451         if (!lastkidop)
3452             lastkidop = pmop;
3453     }
3454
3455     /* Optimise 
3456      *    target  = A.B.C...
3457      *    target .= A.B.C...
3458      */
3459
3460     if (targetop) {
3461         assert(!targmyop);
3462
3463         if (o->op_type == OP_SASSIGN) {
3464             /* Move the target subtree from being the last of o's children
3465              * to being the last of o's preserved children.
3466              * Note the difference between 'target = ...' and 'target .= ...':
3467              * for the former, target is executed last; for the latter,
3468              * first.
3469              */
3470             kid = OpSIBLING(lastkidop);
3471             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3472             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3473             lastkidop->op_next = kid->op_next;
3474             lastkidop = targetop;
3475         }
3476         else {
3477             /* Move the target subtree from being the first of o's
3478              * original children to being the first of *all* o's children.
3479              */
3480             if (lastkidop) {
3481                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3482                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3483             }
3484             else {
3485                 /* if the RHS of .= doesn't contain a concat (e.g.
3486                  * $x .= "foo"), it gets missed by the "strip ops from the
3487                  * tree and add to o" loop earlier */
3488                 assert(topop->op_type != OP_CONCAT);
3489                 if (stringop) {
3490                     /* in e.g. $x .= "$y", move the $y expression
3491                      * from being a child of OP_STRINGIFY to being the
3492                      * second child of the OP_CONCAT
3493                      */
3494                     assert(cUNOPx(stringop)->op_first == topop);
3495                     op_sibling_splice(stringop, NULL, 1, NULL);
3496                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3497                 }
3498                 assert(topop == OpSIBLING(cBINOPo->op_first));
3499                 if (toparg->p)
3500                     op_null(topop);
3501                 lastkidop = topop;
3502             }
3503         }
3504
3505         if (is_targable) {
3506             /* optimise
3507              *  my $lex  = A.B.C...
3508              *     $lex  = A.B.C...
3509              *     $lex .= A.B.C...
3510              * The original padsv op is kept but nulled in case it's the
3511              * entry point for the optree (which it will be for
3512              * '$lex .=  ... '
3513              */
3514             private_flags |= OPpTARGET_MY;
3515             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3516             o->op_targ = targetop->op_targ;
3517             targetop->op_targ = 0;
3518             op_null(targetop);
3519         }
3520         else
3521             flags |= OPf_STACKED;
3522     }
3523     else if (targmyop) {
3524         private_flags |= OPpTARGET_MY;
3525         if (o != targmyop) {
3526             o->op_targ = targmyop->op_targ;
3527             targmyop->op_targ = 0;
3528         }
3529     }
3530
3531     /* detach the emaciated husk of the sprintf/concat optree and free it */
3532     for (;;) {
3533         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3534         if (!kid)
3535             break;
3536         op_free(kid);
3537     }
3538
3539     /* and convert o into a multiconcat */
3540
3541     o->op_flags        = (flags|OPf_KIDS|stacked_last
3542                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3543     o->op_private      = private_flags;
3544     o->op_type         = OP_MULTICONCAT;
3545     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3546     cUNOP_AUXo->op_aux = aux;
3547 }
3548
3549
3550 /* do all the final processing on an optree (e.g. running the peephole
3551  * optimiser on it), then attach it to cv (if cv is non-null)
3552  */
3553
3554 static void
3555 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3556 {
3557     OP **startp;
3558
3559     /* XXX for some reason, evals, require and main optrees are
3560      * never attached to their CV; instead they just hang off
3561      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3562      * and get manually freed when appropriate */
3563     if (cv)
3564         startp = &CvSTART(cv);
3565     else
3566         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3567
3568     *startp = start;
3569     optree->op_private |= OPpREFCOUNTED;
3570     OpREFCNT_set(optree, 1);
3571     optimize_optree(optree);
3572     CALL_PEEP(*startp);
3573     finalize_optree(optree);
3574     S_prune_chain_head(startp);
3575
3576     if (cv) {
3577         /* now that optimizer has done its work, adjust pad values */
3578         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3579                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3580     }
3581 }
3582
3583
3584 /*
3585 =for apidoc optimize_optree
3586
3587 This function applies some optimisations to the optree in top-down order.
3588 It is called before the peephole optimizer, which processes ops in
3589 execution order. Note that finalize_optree() also does a top-down scan,
3590 but is called *after* the peephole optimizer.
3591
3592 =cut
3593 */
3594
3595 void
3596 Perl_optimize_optree(pTHX_ OP* o)
3597 {
3598     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3599
3600     ENTER;
3601     SAVEVPTR(PL_curcop);
3602
3603     optimize_op(o);
3604
3605     LEAVE;
3606 }
3607
3608
3609 /* helper for optimize_optree() which optimises one op then recurses
3610  * to optimise any children.
3611  */
3612
3613 STATIC void
3614 S_optimize_op(pTHX_ OP* o)
3615 {
3616     OP *top_op = o;
3617
3618     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3619
3620     while (1) {
3621         OP * next_kid = NULL;
3622
3623         assert(o->op_type != OP_FREED);
3624
3625         switch (o->op_type) {
3626         case OP_NEXTSTATE:
3627         case OP_DBSTATE:
3628             PL_curcop = ((COP*)o);              /* for warnings */
3629             break;
3630
3631
3632         case OP_CONCAT:
3633         case OP_SASSIGN:
3634         case OP_STRINGIFY:
3635         case OP_SPRINTF:
3636             S_maybe_multiconcat(aTHX_ o);
3637             break;
3638
3639         case OP_SUBST:
3640             if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3641                 /* we can't assume that op_pmreplroot->op_sibparent == o
3642                  * and that it is thus possible to walk back up the tree
3643                  * past op_pmreplroot. So, although we try to avoid
3644                  * recursing through op trees, do it here. After all,
3645                  * there are unlikely to be many nested s///e's within
3646                  * the replacement part of a s///e.
3647                  */
3648                 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3649             }
3650             break;
3651
3652         default:
3653             break;
3654         }
3655
3656         if (o->op_flags & OPf_KIDS)
3657             next_kid = cUNOPo->op_first;
3658
3659         /* if a kid hasn't been nominated to process, continue with the
3660          * next sibling, or if no siblings left, go back to the parent's
3661          * siblings and so on
3662          */
3663         while (!next_kid) {
3664             if (o == top_op)
3665                 return; /* at top; no parents/siblings to try */
3666             if (OpHAS_SIBLING(o))
3667                 next_kid = o->op_sibparent;
3668             else
3669                 o = o->op_sibparent; /*try parent's next sibling */
3670         }
3671
3672       /* this label not yet used. Goto here if any code above sets
3673        * next-kid
3674        get_next_op:
3675        */
3676         o = next_kid;
3677     }
3678 }
3679
3680
3681 /*
3682 =for apidoc finalize_optree
3683
3684 This function finalizes the optree.  Should be called directly after
3685 the complete optree is built.  It does some additional
3686 checking which can't be done in the normal C<ck_>xxx functions and makes
3687 the tree thread-safe.
3688
3689 =cut
3690 */
3691 void
3692 Perl_finalize_optree(pTHX_ OP* o)
3693 {
3694     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3695
3696     ENTER;
3697     SAVEVPTR(PL_curcop);
3698
3699     finalize_op(o);
3700
3701     LEAVE;
3702 }
3703
3704 #ifdef USE_ITHREADS
3705 /* Relocate sv to the pad for thread safety.
3706  * Despite being a "constant", the SV is written to,
3707  * for reference counts, sv_upgrade() etc. */
3708 PERL_STATIC_INLINE void
3709 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3710 {
3711     PADOFFSET ix;
3712     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3713     if (!*svp) return;
3714     ix = pad_alloc(OP_CONST, SVf_READONLY);
3715     SvREFCNT_dec(PAD_SVl(ix));
3716     PAD_SETSV(ix, *svp);
3717     /* XXX I don't know how this isn't readonly already. */
3718     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3719     *svp = NULL;
3720     *targp = ix;
3721 }
3722 #endif
3723
3724 /*
3725 =for apidoc traverse_op_tree
3726
3727 Return the next op in a depth-first traversal of the op tree,
3728 returning NULL when the traversal is complete.
3729
3730 The initial call must supply the root of the tree as both top and o.
3731
3732 For now it's static, but it may be exposed to the API in the future.
3733
3734 =cut
3735 */
3736
3737 STATIC OP*
3738 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3739     OP *sib;
3740
3741     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3742
3743     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3744         return cUNOPo->op_first;
3745     }
3746     else if ((sib = OpSIBLING(o))) {
3747         return sib;
3748     }
3749     else {
3750         OP *parent = o->op_sibparent;
3751         assert(!(o->op_moresib));
3752         while (parent && parent != top) {
3753             OP *sib = OpSIBLING(parent);
3754             if (sib)
3755                 return sib;
3756             parent = parent->op_sibparent;
3757         }
3758
3759         return NULL;
3760     }
3761 }
3762
3763 STATIC void
3764 S_finalize_op(pTHX_ OP* o)
3765 {
3766     OP * const top = o;
3767     PERL_ARGS_ASSERT_FINALIZE_OP;
3768
3769     do {
3770         assert(o->op_type != OP_FREED);
3771
3772         switch (o->op_type) {
3773         case OP_NEXTSTATE:
3774         case OP_DBSTATE:
3775             PL_curcop = ((COP*)o);              /* for warnings */
3776             break;
3777         case OP_EXEC:
3778             if (OpHAS_SIBLING(o)) {
3779                 OP *sib = OpSIBLING(o);
3780                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3781                     && ckWARN(WARN_EXEC)
3782                     && OpHAS_SIBLING(sib))
3783                 {
3784                     const OPCODE type = OpSIBLING(sib)->op_type;
3785                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3786                         const line_t oldline = CopLINE(PL_curcop);
3787                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3788                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3789                             "Statement unlikely to be reached");
3790                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3791                             "\t(Maybe you meant system() when you said exec()?)\n");
3792                         CopLINE_set(PL_curcop, oldline);
3793                     }
3794                 }
3795             }
3796             break;
3797
3798         case OP_GV:
3799             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3800                 GV * const gv = cGVOPo_gv;
3801                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3802                     /* XXX could check prototype here instead of just carping */
3803                     SV * const sv = sv_newmortal();
3804                     gv_efullname3(sv, gv, NULL);
3805                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3806                                 "%" SVf "() called too early to check prototype",
3807                                 SVfARG(sv));
3808                 }
3809             }
3810             break;
3811
3812         case OP_CONST:
3813             if (cSVOPo->op_private & OPpCONST_STRICT)
3814                 no_bareword_allowed(o);
3815 #ifdef USE_ITHREADS
3816             /* FALLTHROUGH */
3817         case OP_HINTSEVAL:
3818             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3819 #endif
3820             break;
3821
3822 #ifdef USE_ITHREADS
3823             /* Relocate all the METHOP's SVs to the pad for thread safety. */
3824         case OP_METHOD_NAMED:
3825         case OP_METHOD_SUPER:
3826         case OP_METHOD_REDIR:
3827         case OP_METHOD_REDIR_SUPER:
3828             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3829             break;
3830 #endif
3831
3832         case OP_HELEM: {
3833             UNOP *rop;
3834             SVOP *key_op;
3835             OP *kid;
3836
3837             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3838                 break;
3839
3840             rop = (UNOP*)((BINOP*)o)->op_first;
3841
3842             goto check_keys;
3843
3844             case OP_HSLICE:
3845                 S_scalar_slice_warning(aTHX_ o);
3846                 /* FALLTHROUGH */
3847
3848             case OP_KVHSLICE:
3849                 kid = OpSIBLING(cLISTOPo->op_first);
3850             if (/* I bet there's always a pushmark... */
3851                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3852                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3853             {
3854                 break;
3855             }
3856
3857             key_op = (SVOP*)(kid->op_type == OP_CONST
3858                              ? kid
3859                              : OpSIBLING(kLISTOP->op_first));
3860
3861             rop = (UNOP*)((LISTOP*)o)->op_last;
3862
3863         check_keys:
3864             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3865                 rop = NULL;
3866             S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3867             break;
3868         }
3869         case OP_NULL:
3870             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3871                 break;
3872             /* FALLTHROUGH */
3873         case OP_ASLICE:
3874             S_scalar_slice_warning(aTHX_ o);
3875             break;
3876
3877         case OP_SUBST: {
3878             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3879                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3880             break;
3881         }
3882         default:
3883             break;
3884         }
3885
3886 #ifdef DEBUGGING
3887         if (o->op_flags & OPf_KIDS) {
3888             OP *kid;
3889
3890             /* check that op_last points to the last sibling, and that
3891              * the last op_sibling/op_sibparent field points back to the
3892              * parent, and that the only ops with KIDS are those which are
3893              * entitled to them */
3894             U32 type = o->op_type;
3895             U32 family;
3896             bool has_last;
3897
3898             if (type == OP_NULL) {
3899                 type = o->op_targ;
3900                 /* ck_glob creates a null UNOP with ex-type GLOB
3901                  * (which is a list op. So pretend it wasn't a listop */
3902                 if (type == OP_GLOB)
3903                     type = OP_NULL;
3904             }
3905             family = PL_opargs[type] & OA_CLASS_MASK;
3906
3907             has_last = (   family == OA_BINOP
3908                         || family == OA_LISTOP
3909                         || family == OA_PMOP
3910                         || family == OA_LOOP
3911                        );
3912             assert(  has_last /* has op_first and op_last, or ...
3913                   ... has (or may have) op_first: */
3914                   || family == OA_UNOP
3915                   || family == OA_UNOP_AUX
3916                   || family == OA_LOGOP
3917                   || family == OA_BASEOP_OR_UNOP
3918                   || family == OA_FILESTATOP
3919                   || family == OA_LOOPEXOP
3920                   || family == OA_METHOP
3921                   || type == OP_CUSTOM
3922                   || type == OP_NULL /* new_logop does this */
3923                   );
3924
3925             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3926                 if (!OpHAS_SIBLING(kid)) {
3927                     if (has_last)
3928                         assert(kid == cLISTOPo->op_last);
3929                     assert(kid->op_sibparent == o);
3930                 }
3931             }
3932         }
3933 #endif
3934     } while (( o = traverse_op_tree(top, o)) != NULL);
3935 }
3936
3937 /*
3938 =for apidoc op_lvalue
3939
3940 Propagate lvalue ("modifiable") context to an op and its children.
3941 C<type> represents the context type, roughly based on the type of op that
3942 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3943 because it has no op type of its own (it is signalled by a flag on
3944 the lvalue op).
3945
3946 This function detects things that can't be modified, such as C<$x+1>, and
3947 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3948 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3949
3950 It also flags things that need to behave specially in an lvalue context,
3951 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3952
3953 =cut
3954 */
3955
3956 static void
3957 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3958 {
3959     CV *cv = PL_compcv;
3960     PadnameLVALUE_on(pn);
3961     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3962         cv = CvOUTSIDE(cv);
3963         /* RT #127786: cv can be NULL due to an eval within the DB package
3964          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3965          * unless they contain an eval, but calling eval within DB
3966          * pretends the eval was done in the caller's scope.
3967          */
3968         if (!cv)
3969             break;
3970         assert(CvPADLIST(cv));
3971         pn =
3972            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3973         assert(PadnameLEN(pn));
3974         PadnameLVALUE_on(pn);
3975     }
3976 }
3977
3978 static bool
3979 S_vivifies(const OPCODE type)
3980 {
3981     switch(type) {
3982     case OP_RV2AV:     case   OP_ASLICE:
3983     case OP_RV2HV:     case OP_KVASLICE:
3984     case OP_RV2SV:     case   OP_HSLICE:
3985     case OP_AELEMFAST: case OP_KVHSLICE:
3986     case OP_HELEM:
3987     case OP_AELEM:
3988         return 1;
3989     }
3990     return 0;
3991 }
3992
3993 static void
3994 S_lvref(pTHX_ OP *o, I32 type)
3995 {
3996     dVAR;
3997     OP *kid;
3998     switch (o->op_type) {
3999     case OP_COND_EXPR:
4000         for (kid = OpSIBLING(cUNOPo->op_first); kid;
4001              kid = OpSIBLING(kid))
4002             S_lvref(aTHX_ kid, type);
4003         /* FALLTHROUGH */
4004     case OP_PUSHMARK:
4005         return;
4006     case OP_RV2AV:
4007         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4008         o->op_flags |= OPf_STACKED;
4009         if (o->op_flags & OPf_PARENS) {
4010             if (o->op_private & OPpLVAL_INTRO) {
4011                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
4012                       "localized parenthesized array in list assignment"));
4013                 return;
4014             }
4015           slurpy:
4016             OpTYPE_set(o, OP_LVAVREF);
4017             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
4018             o->op_flags |= OPf_MOD|OPf_REF;
4019             return;
4020         }
4021         o->op_private |= OPpLVREF_AV;
4022         goto checkgv;
4023     case OP_RV2CV:
4024         kid = cUNOPo->op_first;
4025         if (kid->op_type == OP_NULL)
4026             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
4027                 ->op_first;
4028         o->op_private = OPpLVREF_CV;
4029         if (kid->op_type == OP_GV)
4030             o->op_flags |= OPf_STACKED;
4031         else if (kid->op_type == OP_PADCV) {
4032             o->op_targ = kid->op_targ;
4033             kid->op_targ = 0;
4034             op_free(cUNOPo->op_first);
4035             cUNOPo->op_first = NULL;
4036             o->op_flags &=~ OPf_KIDS;
4037         }
4038         else goto badref;
4039         break;
4040     case OP_RV2HV:
4041         if (o->op_flags & OPf_PARENS) {
4042           parenhash:
4043             yyerror(Perl_form(aTHX_ "Can't modify reference to "
4044                                  "parenthesized hash in list assignment"));
4045                 return;
4046         }
4047         o->op_private |= OPpLVREF_HV;
4048         /* FALLTHROUGH */
4049     case OP_RV2SV:
4050       checkgv:
4051         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4052         o->op_flags |= OPf_STACKED;
4053         break;
4054     case OP_PADHV:
4055         if (o->op_flags & OPf_PARENS) goto parenhash;
4056         o->op_private |= OPpLVREF_HV;
4057         /* FALLTHROUGH */
4058     case OP_PADSV:
4059         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4060         break;
4061     case OP_PADAV:
4062         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4063         if (o->op_flags & OPf_PARENS) goto slurpy;
4064         o->op_private |= OPpLVREF_AV;
4065         break;
4066     case OP_AELEM:
4067     case OP_HELEM:
4068         o->op_private |= OPpLVREF_ELEM;
4069         o->op_flags   |= OPf_STACKED;
4070         break;
4071     case OP_ASLICE:
4072     case OP_HSLICE:
4073         OpTYPE_set(o, OP_LVREFSLICE);
4074         o->op_private &= OPpLVAL_INTRO;
4075         return;
4076     case OP_NULL:
4077         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4078             goto badref;
4079         else if (!(o->op_flags & OPf_KIDS))
4080             return;
4081         if (o->op_targ != OP_LIST) {
4082             S_lvref(aTHX_ cBINOPo->op_first, type);
4083             return;
4084         }
4085         /* FALLTHROUGH */
4086     case OP_LIST:
4087         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
4088             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
4089             S_lvref(aTHX_ kid, type);
4090         }
4091         return;
4092     case OP_STUB:
4093         if (o->op_flags & OPf_PARENS)
4094             return;
4095         /* FALLTHROUGH */
4096     default:
4097       badref:
4098         /* diag_listed_as: Can't modify reference to %s in %s assignment */
4099         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4100                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4101                       ? "do block"
4102                       : OP_DESC(o),
4103                      PL_op_desc[type]));
4104         return;
4105     }
4106     OpTYPE_set(o, OP_LVREF);
4107     o->op_private &=
4108         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4109     if (type == OP_ENTERLOOP)
4110         o->op_private |= OPpLVREF_ITER;
4111 }
4112
4113 PERL_STATIC_INLINE bool
4114 S_potential_mod_type(I32 type)
4115 {
4116     /* Types that only potentially result in modification.  */
4117     return type == OP_GREPSTART || type == OP_ENTERSUB
4118         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
4119 }
4120
4121 OP *
4122 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4123 {
4124     dVAR;
4125     OP *kid;
4126     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4127     int localize = -1;
4128
4129     if (!o || (PL_parser && PL_parser->error_count))
4130         return o;
4131
4132     if ((o->op_private & OPpTARGET_MY)
4133         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4134     {
4135         return o;
4136     }
4137
4138     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
4139
4140     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4141
4142     switch (o->op_type) {
4143     case OP_UNDEF:
4144         PL_modcount++;
4145         return o;
4146     case OP_STUB:
4147         if ((o->op_flags & OPf_PARENS))
4148             break;
4149         goto nomod;
4150     case OP_ENTERSUB:
4151         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4152             !(o->op_flags & OPf_STACKED)) {
4153             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
4154             assert(cUNOPo->op_first->op_type == OP_NULL);
4155             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4156             break;
4157         }
4158         else {                          /* lvalue subroutine call */
4159             o->op_private |= OPpLVAL_INTRO;
4160             PL_modcount = RETURN_UNLIMITED_NUMBER;
4161             if (S_potential_mod_type(type)) {
4162                 o->op_private |= OPpENTERSUB_INARGS;
4163                 break;
4164             }
4165             else {                      /* Compile-time error message: */
4166                 OP *kid = cUNOPo->op_first;
4167                 CV *cv;
4168                 GV *gv;
4169                 SV *namesv;
4170
4171                 if (kid->op_type != OP_PUSHMARK) {
4172                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4173                         Perl_croak(aTHX_
4174                                 "panic: unexpected lvalue entersub "
4175                                 "args: type/targ %ld:%" UVuf,
4176                                 (long)kid->op_type, (UV)kid->op_targ);
4177                     kid = kLISTOP->op_first;
4178                 }
4179                 while (OpHAS_SIBLING(kid))
4180                     kid = OpSIBLING(kid);
4181                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4182                     break;      /* Postpone until runtime */
4183                 }
4184
4185                 kid = kUNOP->op_first;
4186                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4187                     kid = kUNOP->op_first;
4188                 if (kid->op_type == OP_NULL)
4189                     Perl_croak(aTHX_
4190                                "Unexpected constant lvalue entersub "
4191                                "entry via type/targ %ld:%" UVuf,
4192                                (long)kid->op_type, (UV)kid->op_targ);
4193                 if (kid->op_type != OP_GV) {
4194                     break;
4195                 }
4196
4197                 gv = kGVOP_gv;
4198                 cv = isGV(gv)
4199                     ? GvCV(gv)
4200                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4201                         ? MUTABLE_CV(SvRV(gv))
4202                         : NULL;
4203                 if (!cv)
4204                     break;
4205                 if (CvLVALUE(cv))
4206                     break;
4207                 if (flags & OP_LVALUE_NO_CROAK)
4208                     return NULL;
4209
4210                 namesv = cv_name(cv, NULL, 0);
4211                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4212                                      "subroutine call of &%" SVf " in %s",
4213                                      SVfARG(namesv), PL_op_desc[type]),
4214                            SvUTF8(namesv));
4215                 return o;
4216             }
4217         }
4218         /* FALLTHROUGH */
4219     default:
4220       nomod:
4221         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4222         /* grep, foreach, subcalls, refgen */
4223         if (S_potential_mod_type(type))
4224             break;
4225         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4226                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4227                       ? "do block"
4228                       : OP_DESC(o)),
4229                      type ? PL_op_desc[type] : "local"));
4230         return o;
4231
4232     case OP_PREINC:
4233     case OP_PREDEC:
4234     case OP_POW:
4235     case OP_MULTIPLY:
4236     case OP_DIVIDE:
4237     case OP_MODULO:
4238     case OP_ADD:
4239     case OP_SUBTRACT:
4240     case OP_CONCAT:
4241     case OP_LEFT_SHIFT:
4242     case OP_RIGHT_SHIFT:
4243     case OP_BIT_AND:
4244     case OP_BIT_XOR:
4245     case OP_BIT_OR:
4246     case OP_I_MULTIPLY:
4247     case OP_I_DIVIDE:
4248     case OP_I_MODULO:
4249     case OP_I_ADD:
4250     case OP_I_SUBTRACT:
4251         if (!(o->op_flags & OPf_STACKED))
4252             goto nomod;
4253         PL_modcount++;
4254         break;
4255
4256     case OP_REPEAT:
4257         if (o->op_flags & OPf_STACKED) {
4258             PL_modcount++;
4259             break;
4260         }
4261         if (!(o->op_private & OPpREPEAT_DOLIST))
4262             goto nomod;
4263         else {
4264             const I32 mods = PL_modcount;
4265             modkids(cBINOPo->op_first, type);
4266             if (type != OP_AASSIGN)
4267                 goto nomod;
4268             kid = cBINOPo->op_last;
4269             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4270                 const IV iv = SvIV(kSVOP_sv);
4271                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4272                     PL_modcount =
4273                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4274             }
4275             else
4276                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4277         }
4278         break;
4279
4280     case OP_COND_EXPR:
4281         localize = 1;
4282         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4283             op_lvalue(kid, type);
4284         break;
4285
4286     case OP_RV2AV:
4287     case OP_RV2HV:
4288         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4289            PL_modcount = RETURN_UNLIMITED_NUMBER;
4290            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4291               fiable since some contexts need to know.  */
4292            o->op_flags |= OPf_MOD;
4293            return o;
4294         }
4295         /* FALLTHROUGH */
4296     case OP_RV2GV:
4297         if (scalar_mod_type(o, type))
4298             goto nomod;
4299         ref(cUNOPo->op_first, o->op_type);
4300         /* FALLTHROUGH */
4301     case OP_ASLICE:
4302     case OP_HSLICE:
4303         localize = 1;
4304         /* FALLTHROUGH */
4305     case OP_AASSIGN:
4306         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4307         if (type == OP_LEAVESUBLV && (
4308                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4309              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4310            ))
4311             o->op_private |= OPpMAYBE_LVSUB;
4312         /* FALLTHROUGH */
4313     case OP_NEXTSTATE:
4314     case OP_DBSTATE:
4315        PL_modcount = RETURN_UNLIMITED_NUMBER;
4316         break;
4317     case OP_KVHSLICE:
4318     case OP_KVASLICE:
4319     case OP_AKEYS:
4320         if (type == OP_LEAVESUBLV)
4321             o->op_private |= OPpMAYBE_LVSUB;
4322         goto nomod;
4323     case OP_AVHVSWITCH:
4324         if (type == OP_LEAVESUBLV
4325          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4326             o->op_private |= OPpMAYBE_LVSUB;
4327         goto nomod;
4328     case OP_AV2ARYLEN:
4329         PL_hints |= HINT_BLOCK_SCOPE;
4330         if (type == OP_LEAVESUBLV)
4331             o->op_private |= OPpMAYBE_LVSUB;
4332         PL_modcount++;
4333         break;
4334     case OP_RV2SV:
4335         ref(cUNOPo->op_first, o->op_type);
4336         localize = 1;
4337         /* FALLTHROUGH */
4338     case OP_GV:
4339         PL_hints |= HINT_BLOCK_SCOPE;
4340         /* FALLTHROUGH */
4341     case OP_SASSIGN:
4342     case OP_ANDASSIGN:
4343     case OP_ORASSIGN:
4344     case OP_DORASSIGN:
4345         PL_modcount++;
4346         break;
4347
4348     case OP_AELEMFAST:
4349     case OP_AELEMFAST_LEX:
4350         localize = -1;
4351         PL_modcount++;
4352         break;
4353
4354     case OP_PADAV:
4355     case OP_PADHV:
4356        PL_modcount = RETURN_UNLIMITED_NUMBER;
4357         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4358         {
4359            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4360               fiable since some contexts need to know.  */
4361             o->op_flags |= OPf_MOD;
4362             return o;
4363         }
4364         if (scalar_mod_type(o, type))
4365             goto nomod;
4366         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4367           && type == OP_LEAVESUBLV)
4368             o->op_private |= OPpMAYBE_LVSUB;
4369         /* FALLTHROUGH */
4370     case OP_PADSV:
4371         PL_modcount++;
4372         if (!type) /* local() */
4373             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4374                               PNfARG(PAD_COMPNAME(o->op_targ)));
4375         if (!(o->op_private & OPpLVAL_INTRO)
4376          || (  type != OP_SASSIGN && type != OP_AASSIGN
4377             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4378             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4379         break;
4380
4381     case OP_PUSHMARK:
4382         localize = 0;
4383         break;
4384
4385     case OP_KEYS:
4386         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4387             goto nomod;
4388         goto lvalue_func;
4389     case OP_SUBSTR:
4390         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4391             goto nomod;
4392         /* FALLTHROUGH */
4393     case OP_POS:
4394     case OP_VEC:
4395       lvalue_func:
4396         if (type == OP_LEAVESUBLV)
4397             o->op_private |= OPpMAYBE_LVSUB;
4398         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4399             /* substr and vec */
4400             /* If this op is in merely potential (non-fatal) modifiable
4401                context, then apply OP_ENTERSUB context to
4402                the kid op (to avoid croaking).  Other-
4403                wise pass this op’s own type so the correct op is mentioned
4404                in error messages.  */
4405             op_lvalue(OpSIBLING(cBINOPo->op_first),
4406                       S_potential_mod_type(type)
4407                         ? (I32)OP_ENTERSUB
4408                         : o->op_type);
4409         }
4410         break;
4411
4412     case OP_AELEM:
4413     case OP_HELEM:
4414         ref(cBINOPo->op_first, o->op_type);
4415         if (type == OP_ENTERSUB &&
4416              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4417             o->op_private |= OPpLVAL_DEFER;
4418         if (type == OP_LEAVESUBLV)
4419             o->op_private |= OPpMAYBE_LVSUB;
4420         localize = 1;
4421         PL_modcount++;
4422         break;
4423
4424     case OP_LEAVE:
4425     case OP_LEAVELOOP:
4426         o->op_private |= OPpLVALUE;
4427         /* FALLTHROUGH */
4428     case OP_SCOPE:
4429     case OP_ENTER:
4430     case OP_LINESEQ:
4431         localize = 0;
4432         if (o->op_flags & OPf_KIDS)
4433             op_lvalue(cLISTOPo->op_last, type);
4434         break;
4435
4436     case OP_NULL:
4437         localize = 0;
4438         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4439             goto nomod;
4440         else if (!(o->op_flags & OPf_KIDS))
4441             break;
4442
4443         if (o->op_targ != OP_LIST) {
4444             OP *sib = OpSIBLING(cLISTOPo->op_first);
4445             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4446              * that looks like
4447              *
4448              *   null
4449              *      arg
4450              *      trans
4451              *
4452              * compared with things like OP_MATCH which have the argument
4453              * as a child:
4454              *
4455              *   match
4456              *      arg
4457              *
4458              * so handle specially to correctly get "Can't modify" croaks etc
4459              */
4460
4461             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4462             {
4463                 /* this should trigger a "Can't modify transliteration" err */
4464                 op_lvalue(sib, type);
4465             }
4466             op_lvalue(cBINOPo->op_first, type);
4467             break;
4468         }
4469         /* FALLTHROUGH */
4470     case OP_LIST:
4471         localize = 0;
4472         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4473             /* elements might be in void context because the list is
4474                in scalar context or because they are attribute sub calls */
4475             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4476                 op_lvalue(kid, type);
4477         break;
4478
4479     case OP_COREARGS:
4480         return o;
4481
4482     case OP_AND:
4483     case OP_OR:
4484         if (type == OP_LEAVESUBLV
4485          || !S_vivifies(cLOGOPo->op_first->op_type))
4486             op_lvalue(cLOGOPo->op_first, type);
4487         if (type == OP_LEAVESUBLV
4488          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4489             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4490         goto nomod;
4491
4492     case OP_SREFGEN:
4493         if (type == OP_NULL) { /* local */
4494           local_refgen:
4495             if (!FEATURE_MYREF_IS_ENABLED)
4496                 Perl_croak(aTHX_ "The experimental declared_refs "
4497                                  "feature is not enabled");
4498             Perl_ck_warner_d(aTHX_
4499                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4500                     "Declaring references is experimental");
4501             op_lvalue(cUNOPo->op_first, OP_NULL);
4502             return o;
4503         }
4504         if (type != OP_AASSIGN && type != OP_SASSIGN
4505          && type != OP_ENTERLOOP)
4506             goto nomod;
4507         /* Don’t bother applying lvalue context to the ex-list.  */
4508         kid = cUNOPx(cUNOPo->op_first)->op_first;
4509         assert (!OpHAS_SIBLING(kid));
4510         goto kid_2lvref;
4511     case OP_REFGEN:
4512         if (type == OP_NULL) /* local */
4513             goto local_refgen;
4514         if (type != OP_AASSIGN) goto nomod;
4515         kid = cUNOPo->op_first;
4516       kid_2lvref:
4517         {
4518             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4519             S_lvref(aTHX_ kid, type);
4520             if (!PL_parser || PL_parser->error_count == ec) {
4521                 if (!FEATURE_REFALIASING_IS_ENABLED)
4522                     Perl_croak(aTHX_
4523                        "Experimental aliasing via reference not enabled");
4524                 Perl_ck_warner_d(aTHX_
4525                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4526                                 "Aliasing via reference is experimental");
4527             }
4528         }
4529         if (o->op_type == OP_REFGEN)
4530             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4531         op_null(o);
4532         return o;
4533
4534     case OP_SPLIT:
4535         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4536             /* This is actually @array = split.  */
4537             PL_modcount = RETURN_UNLIMITED_NUMBER;
4538             break;
4539         }
4540         goto nomod;
4541
4542     case OP_SCALAR:
4543         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4544         goto nomod;
4545     }
4546
4547     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4548        their argument is a filehandle; thus \stat(".") should not set
4549        it. AMS 20011102 */
4550     if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4551         return o;
4552
4553     if (type != OP_LEAVESUBLV)
4554         o->op_flags |= OPf_MOD;
4555
4556     if (type == OP_AASSIGN || type == OP_SASSIGN)
4557         o->op_flags |= OPf_SPECIAL
4558                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4559     else if (!type) { /* local() */
4560         switch (localize) {
4561         case 1:
4562             o->op_private |= OPpLVAL_INTRO;
4563             o->op_flags &= ~OPf_SPECIAL;
4564             PL_hints |= HINT_BLOCK_SCOPE;
4565             break;
4566         case 0:
4567             break;
4568         case -1:
4569             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4570                            "Useless localization of %s", OP_DESC(o));
4571         }
4572     }
4573     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4574              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4575         o->op_flags |= OPf_REF;
4576     return o;
4577 }
4578
4579 STATIC bool
4580 S_scalar_mod_type(const OP *o, I32 type)
4581 {
4582     switch (type) {
4583     case OP_POS:
4584     case OP_SASSIGN:
4585         if (o && o->op_type == OP_RV2GV)
4586             return FALSE;
4587         /* FALLTHROUGH */
4588     case OP_PREINC:
4589     case OP_PREDEC:
4590     case OP_POSTINC:
4591     case OP_POSTDEC:
4592     case OP_I_PREINC:
4593     case OP_I_PREDEC:
4594     case OP_I_POSTINC:
4595     case OP_I_POSTDEC:
4596     case OP_POW:
4597     case OP_MULTIPLY:
4598     case OP_DIVIDE:
4599     case OP_MODULO:
4600     case OP_REPEAT:
4601     case OP_ADD:
4602     case OP_SUBTRACT:
4603     case OP_I_MULTIPLY:
4604     case OP_I_DIVIDE:
4605     case OP_I_MODULO:
4606     case OP_I_ADD:
4607     case OP_I_SUBTRACT:
4608     case OP_LEFT_SHIFT:
4609     case OP_RIGHT_SHIFT:
4610     case OP_BIT_AND:
4611     case OP_BIT_XOR:
4612     case OP_BIT_OR:
4613     case OP_NBIT_AND:
4614     case OP_NBIT_XOR:
4615     case OP_NBIT_OR:
4616     case OP_SBIT_AND:
4617     case OP_SBIT_XOR:
4618     case OP_SBIT_OR:
4619     case OP_CONCAT:
4620     case OP_SUBST:
4621     case OP_TRANS:
4622     case OP_TRANSR:
4623     case OP_READ:
4624     case OP_SYSREAD:
4625     case OP_RECV:
4626     case OP_ANDASSIGN:
4627     case OP_ORASSIGN:
4628     case OP_DORASSIGN:
4629     case OP_VEC:
4630     case OP_SUBSTR:
4631         return TRUE;
4632     default:
4633         return FALSE;
4634     }
4635 }
4636
4637 STATIC bool
4638 S_is_handle_constructor(const OP *o, I32 numargs)
4639 {
4640     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4641
4642     switch (o->op_type) {
4643     case OP_PIPE_OP:
4644     case OP_SOCKPAIR:
4645         if (numargs == 2)
4646             return TRUE;
4647         /* FALLTHROUGH */
4648     case OP_SYSOPEN:
4649     case OP_OPEN:
4650     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4651     case OP_SOCKET:
4652     case OP_OPEN_DIR:
4653     case OP_ACCEPT:
4654         if (numargs == 1)
4655             return TRUE;
4656         /* FALLTHROUGH */
4657     default:
4658         return FALSE;
4659     }
4660 }
4661
4662 static OP *
4663 S_refkids(pTHX_ OP *o, I32 type)
4664 {
4665     if (o && o->op_flags & OPf_KIDS) {
4666         OP *kid;
4667         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4668             ref(kid, type);
4669     }
4670     return o;
4671 }
4672
4673 OP *
4674 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4675 {
4676     dVAR;
4677     OP *kid;
4678
4679     PERL_ARGS_ASSERT_DOREF;
4680
4681     if (PL_parser && PL_parser->error_count)
4682         return o;
4683
4684     switch (o->op_type) {
4685     case OP_ENTERSUB:
4686         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4687             !(o->op_flags & OPf_STACKED)) {
4688             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4689             assert(cUNOPo->op_first->op_type == OP_NULL);
4690             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4691             o->op_flags |= OPf_SPECIAL;
4692         }
4693         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4694             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4695                               : type == OP_RV2HV ? OPpDEREF_HV
4696                               : OPpDEREF_SV);
4697             o->op_flags |= OPf_MOD;
4698         }
4699
4700         break;
4701
4702     case OP_COND_EXPR:
4703         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))