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