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