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