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