This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_scalar(): indent block
[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     OP *first;
1607
1608     PERL_ARGS_ASSERT_OP_LINKLIST;
1609
1610     if (o->op_next)
1611         return o->op_next;
1612
1613     /* establish postfix order */
1614     first = cUNOPo->op_first;
1615     if (first) {
1616         OP *kid;
1617         o->op_next = LINKLIST(first);
1618         kid = first;
1619         for (;;) {
1620             OP *sibl = OpSIBLING(kid);
1621             if (sibl) {
1622                 kid->op_next = LINKLIST(sibl);
1623                 kid = sibl;
1624             } else {
1625                 kid->op_next = o;
1626                 break;
1627             }
1628         }
1629     }
1630     else
1631         o->op_next = o;
1632
1633     return o->op_next;
1634 }
1635
1636 static OP *
1637 S_scalarkids(pTHX_ OP *o)
1638 {
1639     if (o && o->op_flags & OPf_KIDS) {
1640         OP *kid;
1641         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1642             scalar(kid);
1643     }
1644     return o;
1645 }
1646
1647 STATIC OP *
1648 S_scalarboolean(pTHX_ OP *o)
1649 {
1650     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1651
1652     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1653          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1654         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1655          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1656          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1657         if (ckWARN(WARN_SYNTAX)) {
1658             const line_t oldline = CopLINE(PL_curcop);
1659
1660             if (PL_parser && PL_parser->copline != NOLINE) {
1661                 /* This ensures that warnings are reported at the first line
1662                    of the conditional, not the last.  */
1663                 CopLINE_set(PL_curcop, PL_parser->copline);
1664             }
1665             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1666             CopLINE_set(PL_curcop, oldline);
1667         }
1668     }
1669     return scalar(o);
1670 }
1671
1672 static SV *
1673 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1674 {
1675     assert(o);
1676     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1677            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1678     {
1679         const char funny  = o->op_type == OP_PADAV
1680                          || o->op_type == OP_RV2AV ? '@' : '%';
1681         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1682             GV *gv;
1683             if (cUNOPo->op_first->op_type != OP_GV
1684              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1685                 return NULL;
1686             return varname(gv, funny, 0, NULL, 0, subscript_type);
1687         }
1688         return
1689             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1690     }
1691 }
1692
1693 static SV *
1694 S_op_varname(pTHX_ const OP *o)
1695 {
1696     return S_op_varname_subscript(aTHX_ o, 1);
1697 }
1698
1699 static void
1700 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1701 { /* or not so pretty :-) */
1702     if (o->op_type == OP_CONST) {
1703         *retsv = cSVOPo_sv;
1704         if (SvPOK(*retsv)) {
1705             SV *sv = *retsv;
1706             *retsv = sv_newmortal();
1707             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1708                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1709         }
1710         else if (!SvOK(*retsv))
1711             *retpv = "undef";
1712     }
1713     else *retpv = "...";
1714 }
1715
1716 static void
1717 S_scalar_slice_warning(pTHX_ const OP *o)
1718 {
1719     OP *kid;
1720     const bool h = o->op_type == OP_HSLICE
1721                 || (o->op_type == OP_NULL && o->op_targ == OP_HSLICE);
1722     const char lbrack =
1723         h ? '{' : '[';
1724     const char rbrack =
1725         h ? '}' : ']';
1726     SV *name;
1727     SV *keysv = NULL; /* just to silence compiler warnings */
1728     const char *key = NULL;
1729
1730     if (!(o->op_private & OPpSLICEWARNING))
1731         return;
1732     if (PL_parser && PL_parser->error_count)
1733         /* This warning can be nonsensical when there is a syntax error. */
1734         return;
1735
1736     kid = cLISTOPo->op_first;
1737     kid = OpSIBLING(kid); /* get past pushmark */
1738     /* weed out false positives: any ops that can return lists */
1739     switch (kid->op_type) {
1740     case OP_BACKTICK:
1741     case OP_GLOB:
1742     case OP_READLINE:
1743     case OP_MATCH:
1744     case OP_RV2AV:
1745     case OP_EACH:
1746     case OP_VALUES:
1747     case OP_KEYS:
1748     case OP_SPLIT:
1749     case OP_LIST:
1750     case OP_SORT:
1751     case OP_REVERSE:
1752     case OP_ENTERSUB:
1753     case OP_CALLER:
1754     case OP_LSTAT:
1755     case OP_STAT:
1756     case OP_READDIR:
1757     case OP_SYSTEM:
1758     case OP_TMS:
1759     case OP_LOCALTIME:
1760     case OP_GMTIME:
1761     case OP_ENTEREVAL:
1762         return;
1763     }
1764
1765     /* Don't warn if we have a nulled list either. */
1766     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1767         return;
1768
1769     assert(OpSIBLING(kid));
1770     name = S_op_varname(aTHX_ OpSIBLING(kid));
1771     if (!name) /* XS module fiddling with the op tree */
1772         return;
1773     S_op_pretty(aTHX_ kid, &keysv, &key);
1774     assert(SvPOK(name));
1775     sv_chop(name,SvPVX(name)+1);
1776     if (key)
1777        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1778         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1779                    "Scalar value @%" SVf "%c%s%c better written as $%" SVf
1780                    "%c%s%c",
1781                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1782                     lbrack, key, rbrack);
1783     else
1784        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1785         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1786                    "Scalar value @%" SVf "%c%" SVf "%c better written as $%"
1787                     SVf "%c%" SVf "%c",
1788                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1789                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1790 }
1791
1792
1793
1794 /* apply scalar context to the o subtree */
1795
1796 OP *
1797 Perl_scalar(pTHX_ OP *o)
1798 {
1799     OP * top_op = o;
1800
1801     while (1) {
1802         OP *next_kid = NULL; /* what op (if any) to process next */
1803         OP *kid;
1804
1805         /* assumes no premature commitment */
1806         if (!o || (PL_parser && PL_parser->error_count)
1807              || (o->op_flags & OPf_WANT)
1808              || o->op_type == OP_RETURN)
1809         {
1810             goto do_next;
1811         }
1812
1813         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1814
1815         switch (o->op_type) {
1816         case OP_REPEAT:
1817             scalar(cBINOPo->op_first);
1818             /* convert what initially looked like a list repeat into a
1819              * scalar repeat, e.g. $s = (1) x $n
1820              */
1821             if (o->op_private & OPpREPEAT_DOLIST) {
1822                 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1823                 assert(kid->op_type == OP_PUSHMARK);
1824                 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1825                     op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1826                     o->op_private &=~ OPpREPEAT_DOLIST;
1827                 }
1828             }
1829             break;
1830
1831         case OP_OR:
1832         case OP_AND:
1833         case OP_COND_EXPR:
1834             /* impose scalar context on everything except the condition */
1835             next_kid = OpSIBLING(cUNOPo->op_first);
1836             break;
1837
1838         default:
1839             if (o->op_flags & OPf_KIDS)
1840                 next_kid = cUNOPo->op_first; /* do all kids */
1841             break;
1842
1843         /* the children of these ops are usually a list of statements,
1844          * except the leaves, whose first child is a corresponding enter
1845          */
1846         case OP_SCOPE:
1847         case OP_LINESEQ:
1848         case OP_LIST:
1849             kid = cLISTOPo->op_first;
1850             goto do_kids;
1851         case OP_LEAVE:
1852         case OP_LEAVETRY:
1853             kid = cLISTOPo->op_first;
1854             scalar(kid);
1855             kid = OpSIBLING(kid);
1856         do_kids:
1857             while (kid) {
1858                 OP *sib = OpSIBLING(kid);
1859                 if (sib && kid->op_type != OP_LEAVEWHEN
1860                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
1861                     || (  sib->op_targ != OP_NEXTSTATE
1862                        && sib->op_targ != OP_DBSTATE  )))
1863                     scalarvoid(kid);
1864                 else
1865                     scalar(kid);
1866                 kid = sib;
1867             }
1868             PL_curcop = &PL_compiling;
1869             break;
1870
1871         case OP_SORT:
1872             Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1873             break;
1874
1875         case OP_KVHSLICE:
1876         case OP_KVASLICE:
1877         {
1878             /* Warn about scalar context */
1879             const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1880             const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1881             SV *name;
1882             SV *keysv;
1883             const char *key = NULL;
1884
1885             /* This warning can be nonsensical when there is a syntax error. */
1886             if (PL_parser && PL_parser->error_count)
1887                 break;
1888
1889             if (!ckWARN(WARN_SYNTAX)) break;
1890
1891             kid = cLISTOPo->op_first;
1892             kid = OpSIBLING(kid); /* get past pushmark */
1893             assert(OpSIBLING(kid));
1894             name = S_op_varname(aTHX_ OpSIBLING(kid));
1895             if (!name) /* XS module fiddling with the op tree */
1896                 break;
1897             S_op_pretty(aTHX_ kid, &keysv, &key);
1898             assert(SvPOK(name));
1899             sv_chop(name,SvPVX(name)+1);
1900             if (key)
1901       /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1902                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1903                            "%%%" SVf "%c%s%c in scalar context better written "
1904                            "as $%" SVf "%c%s%c",
1905                             SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1906                             lbrack, key, rbrack);
1907             else
1908       /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1909                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1910                            "%%%" SVf "%c%" SVf "%c in scalar context better "
1911                            "written as $%" SVf "%c%" SVf "%c",
1912                             SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1913                             SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1914         }
1915         } /* switch */
1916
1917         /* If next_kid is set, someone in the code above wanted us to process
1918          * that kid and all its remaining siblings.  Otherwise, work our way
1919          * back up the tree */
1920       do_next:
1921         while (!next_kid) {
1922             if (o == top_op)
1923                 return top_op; /* at top; no parents/siblings to try */
1924             if (OpHAS_SIBLING(o))
1925                 next_kid = o->op_sibparent;
1926             else
1927                 o = o->op_sibparent; /*try parent's next sibling */
1928
1929         }
1930         o = next_kid;
1931     } /* while */
1932 }
1933
1934
1935 OP *
1936 Perl_scalarvoid(pTHX_ OP *arg)
1937 {
1938     dVAR;
1939     OP *kid;
1940     SV* sv;
1941     OP *o = arg;
1942
1943     PERL_ARGS_ASSERT_SCALARVOID;
1944
1945     while (1) {
1946         U8 want;
1947         SV *useless_sv = NULL;
1948         const char* useless = NULL;
1949         OP * next_kid = NULL;
1950
1951         if (o->op_type == OP_NEXTSTATE
1952             || o->op_type == OP_DBSTATE
1953             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1954                                           || o->op_targ == OP_DBSTATE)))
1955             PL_curcop = (COP*)o;                /* for warning below */
1956
1957         /* assumes no premature commitment */
1958         want = o->op_flags & OPf_WANT;
1959         if ((want && want != OPf_WANT_SCALAR)
1960             || (PL_parser && PL_parser->error_count)
1961             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1962         {
1963             goto get_next_op;
1964         }
1965
1966         if ((o->op_private & OPpTARGET_MY)
1967             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1968         {
1969             /* newASSIGNOP has already applied scalar context, which we
1970                leave, as if this op is inside SASSIGN.  */
1971             goto get_next_op;
1972         }
1973
1974         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1975
1976         switch (o->op_type) {
1977         default:
1978             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1979                 break;
1980             /* FALLTHROUGH */
1981         case OP_REPEAT:
1982             if (o->op_flags & OPf_STACKED)
1983                 break;
1984             if (o->op_type == OP_REPEAT)
1985                 scalar(cBINOPo->op_first);
1986             goto func_ops;
1987         case OP_CONCAT:
1988             if ((o->op_flags & OPf_STACKED) &&
1989                     !(o->op_private & OPpCONCAT_NESTED))
1990                 break;
1991             goto func_ops;
1992         case OP_SUBSTR:
1993             if (o->op_private == 4)
1994                 break;
1995             /* FALLTHROUGH */
1996         case OP_WANTARRAY:
1997         case OP_GV:
1998         case OP_SMARTMATCH:
1999         case OP_AV2ARYLEN:
2000         case OP_REF:
2001         case OP_REFGEN:
2002         case OP_SREFGEN:
2003         case OP_DEFINED:
2004         case OP_HEX:
2005         case OP_OCT:
2006         case OP_LENGTH:
2007         case OP_VEC:
2008         case OP_INDEX:
2009         case OP_RINDEX:
2010         case OP_SPRINTF:
2011         case OP_KVASLICE:
2012         case OP_KVHSLICE:
2013         case OP_UNPACK:
2014         case OP_PACK:
2015         case OP_JOIN:
2016         case OP_LSLICE:
2017         case OP_ANONLIST:
2018         case OP_ANONHASH:
2019         case OP_SORT:
2020         case OP_REVERSE:
2021         case OP_RANGE:
2022         case OP_FLIP:
2023         case OP_FLOP:
2024         case OP_CALLER:
2025         case OP_FILENO:
2026         case OP_EOF:
2027         case OP_TELL:
2028         case OP_GETSOCKNAME:
2029         case OP_GETPEERNAME:
2030         case OP_READLINK:
2031         case OP_TELLDIR:
2032         case OP_GETPPID:
2033         case OP_GETPGRP:
2034         case OP_GETPRIORITY:
2035         case OP_TIME:
2036         case OP_TMS:
2037         case OP_LOCALTIME:
2038         case OP_GMTIME:
2039         case OP_GHBYNAME:
2040         case OP_GHBYADDR:
2041         case OP_GHOSTENT:
2042         case OP_GNBYNAME:
2043         case OP_GNBYADDR:
2044         case OP_GNETENT:
2045         case OP_GPBYNAME:
2046         case OP_GPBYNUMBER:
2047         case OP_GPROTOENT:
2048         case OP_GSBYNAME:
2049         case OP_GSBYPORT:
2050         case OP_GSERVENT:
2051         case OP_GPWNAM:
2052         case OP_GPWUID:
2053         case OP_GGRNAM:
2054         case OP_GGRGID:
2055         case OP_GETLOGIN:
2056         case OP_PROTOTYPE:
2057         case OP_RUNCV:
2058         func_ops:
2059             useless = OP_DESC(o);
2060             break;
2061
2062         case OP_GVSV:
2063         case OP_PADSV:
2064         case OP_PADAV:
2065         case OP_PADHV:
2066         case OP_PADANY:
2067         case OP_AELEM:
2068         case OP_AELEMFAST:
2069         case OP_AELEMFAST_LEX:
2070         case OP_ASLICE:
2071         case OP_HELEM:
2072         case OP_HSLICE:
2073             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2074                 /* Otherwise it's "Useless use of grep iterator" */
2075                 useless = OP_DESC(o);
2076             break;
2077
2078         case OP_SPLIT:
2079             if (!(o->op_private & OPpSPLIT_ASSIGN))
2080                 useless = OP_DESC(o);
2081             break;
2082
2083         case OP_NOT:
2084             kid = cUNOPo->op_first;
2085             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2086                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2087                 goto func_ops;
2088             }
2089             useless = "negative pattern binding (!~)";
2090             break;
2091
2092         case OP_SUBST:
2093             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2094                 useless = "non-destructive substitution (s///r)";
2095             break;
2096
2097         case OP_TRANSR:
2098             useless = "non-destructive transliteration (tr///r)";
2099             break;
2100
2101         case OP_RV2GV:
2102         case OP_RV2SV:
2103         case OP_RV2AV:
2104         case OP_RV2HV:
2105             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2106                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2107                 useless = "a variable";
2108             break;
2109
2110         case OP_CONST:
2111             sv = cSVOPo_sv;
2112             if (cSVOPo->op_private & OPpCONST_STRICT)
2113                 no_bareword_allowed(o);
2114             else {
2115                 if (ckWARN(WARN_VOID)) {
2116                     NV nv;
2117                     /* don't warn on optimised away booleans, eg
2118                      * use constant Foo, 5; Foo || print; */
2119                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2120                         useless = NULL;
2121                     /* the constants 0 and 1 are permitted as they are
2122                        conventionally used as dummies in constructs like
2123                        1 while some_condition_with_side_effects;  */
2124                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2125                         useless = NULL;
2126                     else if (SvPOK(sv)) {
2127                         SV * const dsv = newSVpvs("");
2128                         useless_sv
2129                             = Perl_newSVpvf(aTHX_
2130                                             "a constant (%s)",
2131                                             pv_pretty(dsv, SvPVX_const(sv),
2132                                                       SvCUR(sv), 32, NULL, NULL,
2133                                                       PERL_PV_PRETTY_DUMP
2134                                                       | PERL_PV_ESCAPE_NOCLEAR
2135                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2136                         SvREFCNT_dec_NN(dsv);
2137                     }
2138                     else if (SvOK(sv)) {
2139                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2140                     }
2141                     else
2142                         useless = "a constant (undef)";
2143                 }
2144             }
2145             op_null(o);         /* don't execute or even remember it */
2146             break;
2147
2148         case OP_POSTINC:
2149             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2150             break;
2151
2152         case OP_POSTDEC:
2153             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2154             break;
2155
2156         case OP_I_POSTINC:
2157             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2158             break;
2159
2160         case OP_I_POSTDEC:
2161             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2162             break;
2163
2164         case OP_SASSIGN: {
2165             OP *rv2gv;
2166             UNOP *refgen, *rv2cv;
2167             LISTOP *exlist;
2168
2169             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2170                 break;
2171
2172             rv2gv = ((BINOP *)o)->op_last;
2173             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2174                 break;
2175
2176             refgen = (UNOP *)((BINOP *)o)->op_first;
2177
2178             if (!refgen || (refgen->op_type != OP_REFGEN
2179                             && refgen->op_type != OP_SREFGEN))
2180                 break;
2181
2182             exlist = (LISTOP *)refgen->op_first;
2183             if (!exlist || exlist->op_type != OP_NULL
2184                 || exlist->op_targ != OP_LIST)
2185                 break;
2186
2187             if (exlist->op_first->op_type != OP_PUSHMARK
2188                 && exlist->op_first != exlist->op_last)
2189                 break;
2190
2191             rv2cv = (UNOP*)exlist->op_last;
2192
2193             if (rv2cv->op_type != OP_RV2CV)
2194                 break;
2195
2196             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2197             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2198             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2199
2200             o->op_private |= OPpASSIGN_CV_TO_GV;
2201             rv2gv->op_private |= OPpDONT_INIT_GV;
2202             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2203
2204             break;
2205         }
2206
2207         case OP_AASSIGN: {
2208             inplace_aassign(o);
2209             break;
2210         }
2211
2212         case OP_OR:
2213         case OP_AND:
2214             kid = cLOGOPo->op_first;
2215             if (kid->op_type == OP_NOT
2216                 && (kid->op_flags & OPf_KIDS)) {
2217                 if (o->op_type == OP_AND) {
2218                     OpTYPE_set(o, OP_OR);
2219                 } else {
2220                     OpTYPE_set(o, OP_AND);
2221                 }
2222                 op_null(kid);
2223             }
2224             /* FALLTHROUGH */
2225
2226         case OP_DOR:
2227         case OP_COND_EXPR:
2228         case OP_ENTERGIVEN:
2229         case OP_ENTERWHEN:
2230             next_kid = OpSIBLING(cUNOPo->op_first);
2231         break;
2232
2233         case OP_NULL:
2234             if (o->op_flags & OPf_STACKED)
2235                 break;
2236             /* FALLTHROUGH */
2237         case OP_NEXTSTATE:
2238         case OP_DBSTATE:
2239         case OP_ENTERTRY:
2240         case OP_ENTER:
2241             if (!(o->op_flags & OPf_KIDS))
2242                 break;
2243             /* FALLTHROUGH */
2244         case OP_SCOPE:
2245         case OP_LEAVE:
2246         case OP_LEAVETRY:
2247         case OP_LEAVELOOP:
2248         case OP_LINESEQ:
2249         case OP_LEAVEGIVEN:
2250         case OP_LEAVEWHEN:
2251         kids:
2252             next_kid = cLISTOPo->op_first;
2253             break;
2254         case OP_LIST:
2255             /* If the first kid after pushmark is something that the padrange
2256                optimisation would reject, then null the list and the pushmark.
2257             */
2258             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2259                 && (  !(kid = OpSIBLING(kid))
2260                       || (  kid->op_type != OP_PADSV
2261                             && kid->op_type != OP_PADAV
2262                             && kid->op_type != OP_PADHV)
2263                       || kid->op_private & ~OPpLVAL_INTRO
2264                       || !(kid = OpSIBLING(kid))
2265                       || (  kid->op_type != OP_PADSV
2266                             && kid->op_type != OP_PADAV
2267                             && kid->op_type != OP_PADHV)
2268                       || kid->op_private & ~OPpLVAL_INTRO)
2269             ) {
2270                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2271                 op_null(o); /* NULL the list */
2272             }
2273             goto kids;
2274         case OP_ENTEREVAL:
2275             scalarkids(o);
2276             break;
2277         case OP_SCALAR:
2278             scalar(o);
2279             break;
2280         }
2281
2282         if (useless_sv) {
2283             /* mortalise it, in case warnings are fatal.  */
2284             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2285                            "Useless use of %" SVf " in void context",
2286                            SVfARG(sv_2mortal(useless_sv)));
2287         }
2288         else if (useless) {
2289             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2290                            "Useless use of %s in void context",
2291                            useless);
2292         }
2293
2294       get_next_op:
2295         /* if a kid hasn't been nominated to process, continue with the
2296          * next sibling, or if no siblings left, go back to the parent's
2297          * siblings and so on
2298          */
2299         while (!next_kid) {
2300             if (o == arg)
2301                 return arg; /* at top; no parents/siblings to try */
2302             if (OpHAS_SIBLING(o))
2303                 next_kid = o->op_sibparent;
2304             else
2305                 o = o->op_sibparent; /*try parent's next sibling */
2306         }
2307         o = next_kid;
2308     }
2309
2310     return arg;
2311 }
2312
2313
2314 static OP *
2315 S_listkids(pTHX_ OP *o)
2316 {
2317     if (o && o->op_flags & OPf_KIDS) {
2318         OP *kid;
2319         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2320             list(kid);
2321     }
2322     return o;
2323 }
2324
2325
2326 /* apply list context to the o subtree */
2327
2328 OP *
2329 Perl_list(pTHX_ OP *o)
2330 {
2331     OP * top_op = o;
2332
2333     while (1) {
2334         OP *next_kid = NULL; /* what op (if any) to process next */
2335
2336         OP *kid;
2337
2338         /* assumes no premature commitment */
2339         if (!o || (o->op_flags & OPf_WANT)
2340              || (PL_parser && PL_parser->error_count)
2341              || o->op_type == OP_RETURN)
2342         {
2343             goto do_next;
2344         }
2345
2346         if ((o->op_private & OPpTARGET_MY)
2347             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2348         {
2349             goto do_next;                               /* As if inside SASSIGN */
2350         }
2351
2352         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2353
2354         switch (o->op_type) {
2355         case OP_REPEAT:
2356             if (o->op_private & OPpREPEAT_DOLIST
2357              && !(o->op_flags & OPf_STACKED))
2358             {
2359                 list(cBINOPo->op_first);
2360                 kid = cBINOPo->op_last;
2361                 /* optimise away (.....) x 1 */
2362                 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2363                  && SvIVX(kSVOP_sv) == 1)
2364                 {
2365                     op_null(o); /* repeat */
2366                     op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2367                     /* const (rhs): */
2368                     op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2369                 }
2370             }
2371             break;
2372
2373         case OP_OR:
2374         case OP_AND:
2375         case OP_COND_EXPR:
2376             /* impose list context on everything except the condition */
2377             next_kid = OpSIBLING(cUNOPo->op_first);
2378             break;
2379
2380         default:
2381             if (!(o->op_flags & OPf_KIDS))
2382                 break;
2383             /* possibly flatten 1..10 into a constant array */
2384             if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2385                 list(cBINOPo->op_first);
2386                 gen_constant_list(o);
2387                 goto do_next;
2388             }
2389             next_kid = cUNOPo->op_first; /* do all kids */
2390             break;
2391
2392         case OP_LIST:
2393             if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2394                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2395                 op_null(o); /* NULL the list */
2396             }
2397             if (o->op_flags & OPf_KIDS)
2398                 next_kid = cUNOPo->op_first; /* do all kids */
2399             break;
2400
2401         /* the children of these ops are usually a list of statements,
2402          * except the leaves, whose first child is a corresponding enter
2403          */
2404         case OP_SCOPE:
2405         case OP_LINESEQ:
2406             kid = cLISTOPo->op_first;
2407             goto do_kids;
2408         case OP_LEAVE:
2409         case OP_LEAVETRY:
2410             kid = cLISTOPo->op_first;
2411             list(kid);
2412             kid = OpSIBLING(kid);
2413         do_kids:
2414             while (kid) {
2415                 OP *sib = OpSIBLING(kid);
2416                 /* Apply void context to all kids except the last, which
2417                  * is list. E.g.
2418                  *      @a = do { void; void; list }
2419                  * Except that 'when's are always list context, e.g.
2420                  *      @a = do { given(..) {
2421                     *                 when (..) { list }
2422                     *                 when (..) { list }
2423                     *                 ...
2424                     *                }}
2425                     */
2426                 if (!sib) {
2427                     /* tail call optimise calling list() on the last kid */
2428                     next_kid = kid;
2429                     goto do_next;
2430                 }
2431                 else if (kid->op_type == OP_LEAVEWHEN)
2432                     list(kid);
2433                 else
2434                     scalarvoid(kid);
2435                 kid = sib;
2436             }
2437             NOT_REACHED; /* NOTREACHED */
2438             break;
2439
2440         }
2441
2442         /* If next_kid is set, someone in the code above wanted us to process
2443          * that kid and all its remaining siblings.  Otherwise, work our way
2444          * back up the tree */
2445       do_next:
2446         while (!next_kid) {
2447             if (o == top_op)
2448                 return top_op; /* at top; no parents/siblings to try */
2449             if (OpHAS_SIBLING(o))
2450                 next_kid = o->op_sibparent;
2451             else {
2452                 o = o->op_sibparent; /*try parent's next sibling */
2453                 switch (o->op_type) {
2454                 case OP_SCOPE:
2455                 case OP_LINESEQ:
2456                 case OP_LIST:
2457                 case OP_LEAVE:
2458                 case OP_LEAVETRY:
2459                     /* should really restore PL_curcop to its old value, but
2460                      * setting it to PL_compiling is better than do nothing */
2461                     PL_curcop = &PL_compiling;
2462                 }
2463             }
2464
2465
2466         }
2467         o = next_kid;
2468     } /* while */
2469 }
2470
2471
2472 static OP *
2473 S_scalarseq(pTHX_ OP *o)
2474 {
2475     if (o) {
2476         const OPCODE type = o->op_type;
2477
2478         if (type == OP_LINESEQ || type == OP_SCOPE ||
2479             type == OP_LEAVE || type == OP_LEAVETRY)
2480         {
2481             OP *kid, *sib;
2482             for (kid = cLISTOPo->op_first; kid; kid = sib) {
2483                 if ((sib = OpSIBLING(kid))
2484                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2485                     || (  sib->op_targ != OP_NEXTSTATE
2486                        && sib->op_targ != OP_DBSTATE  )))
2487                 {
2488                     scalarvoid(kid);
2489                 }
2490             }
2491             PL_curcop = &PL_compiling;
2492         }
2493         o->op_flags &= ~OPf_PARENS;
2494         if (PL_hints & HINT_BLOCK_SCOPE)
2495             o->op_flags |= OPf_PARENS;
2496     }
2497     else
2498         o = newOP(OP_STUB, 0);
2499     return o;
2500 }
2501
2502 STATIC OP *
2503 S_modkids(pTHX_ OP *o, I32 type)
2504 {
2505     if (o && o->op_flags & OPf_KIDS) {
2506         OP *kid;
2507         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2508             op_lvalue(kid, type);
2509     }
2510     return o;
2511 }
2512
2513
2514 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2515  * const fields. Also, convert CONST keys to HEK-in-SVs.
2516  * rop    is the op that retrieves the hash;
2517  * key_op is the first key
2518  * real   if false, only check (and possibly croak); don't update op
2519  */
2520
2521 STATIC void
2522 S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2523 {
2524     PADNAME *lexname;
2525     GV **fields;
2526     bool check_fields;
2527
2528     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2529     if (rop) {
2530         if (rop->op_first->op_type == OP_PADSV)
2531             /* @$hash{qw(keys here)} */
2532             rop = (UNOP*)rop->op_first;
2533         else {
2534             /* @{$hash}{qw(keys here)} */
2535             if (rop->op_first->op_type == OP_SCOPE
2536                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2537                 {
2538                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2539                 }
2540             else
2541                 rop = NULL;
2542         }
2543     }
2544
2545     lexname = NULL; /* just to silence compiler warnings */
2546     fields  = NULL; /* just to silence compiler warnings */
2547
2548     check_fields =
2549             rop
2550          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2551              SvPAD_TYPED(lexname))
2552          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2553          && isGV(*fields) && GvHV(*fields);
2554
2555     for (; key_op; key_op = (SVOP*)OpSIBLING(key_op)) {
2556         SV **svp, *sv;
2557         if (key_op->op_type != OP_CONST)
2558             continue;
2559         svp = cSVOPx_svp(key_op);
2560
2561         /* make sure it's not a bareword under strict subs */
2562         if (key_op->op_private & OPpCONST_BARE &&
2563             key_op->op_private & OPpCONST_STRICT)
2564         {
2565             no_bareword_allowed((OP*)key_op);
2566         }
2567
2568         /* Make the CONST have a shared SV */
2569         if (   !SvIsCOW_shared_hash(sv = *svp)
2570             && SvTYPE(sv) < SVt_PVMG
2571             && SvOK(sv)
2572             && !SvROK(sv)
2573             && real)
2574         {
2575             SSize_t keylen;
2576             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2577             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2578             SvREFCNT_dec_NN(sv);
2579             *svp = nsv;
2580         }
2581
2582         if (   check_fields
2583             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2584         {
2585             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2586                         "in variable %" PNf " of type %" HEKf,
2587                         SVfARG(*svp), PNfARG(lexname),
2588                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2589         }
2590     }
2591 }
2592
2593 /* info returned by S_sprintf_is_multiconcatable() */
2594
2595 struct sprintf_ismc_info {
2596     SSize_t nargs;    /* num of args to sprintf (not including the format) */
2597     char  *start;     /* start of raw format string */
2598     char  *end;       /* bytes after end of raw format string */
2599     STRLEN total_len; /* total length (in bytes) of format string, not
2600                          including '%s' and  half of '%%' */
2601     STRLEN variant;   /* number of bytes by which total_len_p would grow
2602                          if upgraded to utf8 */
2603     bool   utf8;      /* whether the format is utf8 */
2604 };
2605
2606
2607 /* is the OP_SPRINTF o suitable for converting into a multiconcat op?
2608  * i.e. its format argument is a const string with only '%s' and '%%'
2609  * formats, and the number of args is known, e.g.
2610  *    sprintf "a=%s f=%s", $a[0], scalar(f());
2611  * but not
2612  *    sprintf "i=%d a=%s f=%s", $i, @a, f();
2613  *
2614  * If successful, the sprintf_ismc_info struct pointed to by info will be
2615  * populated.
2616  */
2617
2618 STATIC bool
2619 S_sprintf_is_multiconcatable(pTHX_ OP *o,struct sprintf_ismc_info *info)
2620 {
2621     OP    *pm, *constop, *kid;
2622     SV    *sv;
2623     char  *s, *e, *p;
2624     SSize_t nargs, nformats;
2625     STRLEN cur, total_len, variant;
2626     bool   utf8;
2627
2628     /* if sprintf's behaviour changes, die here so that someone
2629      * can decide whether to enhance this function or skip optimising
2630      * under those new circumstances */
2631     assert(!(o->op_flags & OPf_STACKED));
2632     assert(!(PL_opargs[OP_SPRINTF] & OA_TARGLEX));
2633     assert(!(o->op_private & ~OPpARG4_MASK));
2634
2635     pm = cUNOPo->op_first;
2636     if (pm->op_type != OP_PUSHMARK) /* weird coreargs stuff */
2637         return FALSE;
2638     constop = OpSIBLING(pm);
2639     if (!constop || constop->op_type != OP_CONST)
2640         return FALSE;
2641     sv = cSVOPx_sv(constop);
2642     if (SvMAGICAL(sv) || !SvPOK(sv))
2643         return FALSE;
2644
2645     s = SvPV(sv, cur);
2646     e = s + cur;
2647
2648     /* Scan format for %% and %s and work out how many %s there are.
2649      * Abandon if other format types are found.
2650      */
2651
2652     nformats  = 0;
2653     total_len = 0;
2654     variant   = 0;
2655
2656     for (p = s; p < e; p++) {
2657         if (*p != '%') {
2658             total_len++;
2659             if (!UTF8_IS_INVARIANT(*p))
2660                 variant++;
2661             continue;
2662         }
2663         p++;
2664         if (p >= e)
2665             return FALSE; /* lone % at end gives "Invalid conversion" */
2666         if (*p == '%')
2667             total_len++;
2668         else if (*p == 's')
2669             nformats++;
2670         else
2671             return FALSE;
2672     }
2673
2674     if (!nformats || nformats > PERL_MULTICONCAT_MAXARG)
2675         return FALSE;
2676
2677     utf8 = cBOOL(SvUTF8(sv));
2678     if (utf8)
2679         variant = 0;
2680
2681     /* scan args; they must all be in scalar cxt */
2682
2683     nargs = 0;
2684     kid = OpSIBLING(constop);
2685
2686     while (kid) {
2687         if ((kid->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2688             return FALSE;
2689         nargs++;
2690         kid = OpSIBLING(kid);
2691     }
2692
2693     if (nargs != nformats)
2694         return FALSE; /* e.g. sprintf("%s%s", $a); */
2695
2696
2697     info->nargs      = nargs;
2698     info->start      = s;
2699     info->end        = e;
2700     info->total_len  = total_len;
2701     info->variant    = variant;
2702     info->utf8       = utf8;
2703
2704     return TRUE;
2705 }
2706
2707
2708
2709 /* S_maybe_multiconcat():
2710  *
2711  * given an OP_STRINGIFY, OP_SASSIGN, OP_CONCAT or OP_SPRINTF op, possibly
2712  * convert it (and its children) into an OP_MULTICONCAT. See the code
2713  * comments just before pp_multiconcat() for the full details of what
2714  * OP_MULTICONCAT supports.
2715  *
2716  * Basically we're looking for an optree with a chain of OP_CONCATS down
2717  * the LHS (or an OP_SPRINTF), with possibly an OP_SASSIGN, and/or
2718  * OP_STRINGIFY, and/or OP_CONCAT acting as '.=' at its head, e.g.
2719  *
2720  *      $x = "$a$b-$c"
2721  *
2722  *  looks like
2723  *
2724  *      SASSIGN
2725  *         |
2726  *      STRINGIFY   -- PADSV[$x]
2727  *         |
2728  *         |
2729  *      ex-PUSHMARK -- CONCAT/S
2730  *                        |
2731  *                     CONCAT/S  -- PADSV[$d]
2732  *                        |
2733  *                     CONCAT    -- CONST["-"]
2734  *                        |
2735  *                     PADSV[$a] -- PADSV[$b]
2736  *
2737  * Note that at this stage the OP_SASSIGN may have already been optimised
2738  * away with OPpTARGET_MY set on the OP_STRINGIFY or OP_CONCAT.
2739  */
2740
2741 STATIC void
2742 S_maybe_multiconcat(pTHX_ OP *o)
2743 {
2744     dVAR;
2745     OP *lastkidop;   /* the right-most of any kids unshifted onto o */
2746     OP *topop;       /* the top-most op in the concat tree (often equals o,
2747                         unless there are assign/stringify ops above it */
2748     OP *parentop;    /* the parent op of topop (or itself if no parent) */
2749     OP *targmyop;    /* the op (if any) with the OPpTARGET_MY flag */
2750     OP *targetop;    /* the op corresponding to target=... or target.=... */
2751     OP *stringop;    /* the OP_STRINGIFY op, if any */
2752     OP *nextop;      /* used for recreating the op_next chain without consts */
2753     OP *kid;         /* general-purpose op pointer */
2754     UNOP_AUX_item *aux;
2755     UNOP_AUX_item *lenp;
2756     char *const_str, *p;
2757     struct sprintf_ismc_info sprintf_info;
2758
2759                      /* store info about each arg in args[];
2760                       * toparg is the highest used slot; argp is a general
2761                       * pointer to args[] slots */
2762     struct {
2763         void *p;      /* initially points to const sv (or null for op);
2764                          later, set to SvPV(constsv), with ... */
2765         STRLEN len;   /* ... len set to SvPV(..., len) */
2766     } *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
2767
2768     SSize_t nargs  = 0;
2769     SSize_t nconst = 0;
2770     SSize_t nadjconst  = 0; /* adjacent consts - may be demoted to args */
2771     STRLEN variant;
2772     bool utf8 = FALSE;
2773     bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
2774                                  the last-processed arg will the LHS of one,
2775                                  as args are processed in reverse order */
2776     U8   stacked_last = 0;   /* whether the last seen concat op was STACKED */
2777     STRLEN total_len  = 0;   /* sum of the lengths of the const segments */
2778     U8 flags          = 0;   /* what will become the op_flags and ... */
2779     U8 private_flags  = 0;   /* ... op_private of the multiconcat op */
2780     bool is_sprintf = FALSE; /* we're optimising an sprintf */
2781     bool is_targable  = FALSE; /* targetop is an OPpTARGET_MY candidate */
2782     bool prev_was_const = FALSE; /* previous arg was a const */
2783
2784     /* -----------------------------------------------------------------
2785      * Phase 1:
2786      *
2787      * Examine the optree non-destructively to determine whether it's
2788      * suitable to be converted into an OP_MULTICONCAT. Accumulate
2789      * information about the optree in args[].
2790      */
2791
2792     argp     = args;
2793     targmyop = NULL;
2794     targetop = NULL;
2795     stringop = NULL;
2796     topop    = o;
2797     parentop = o;
2798
2799     assert(   o->op_type == OP_SASSIGN
2800            || o->op_type == OP_CONCAT
2801            || o->op_type == OP_SPRINTF
2802            || o->op_type == OP_STRINGIFY);
2803
2804     Zero(&sprintf_info, 1, struct sprintf_ismc_info);
2805
2806     /* first see if, at the top of the tree, there is an assign,
2807      * append and/or stringify */
2808
2809     if (topop->op_type == OP_SASSIGN) {
2810         /* expr = ..... */
2811         if (o->op_ppaddr != PL_ppaddr[OP_SASSIGN])
2812             return;
2813         if (o->op_private & (OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV))
2814             return;
2815         assert(!(o->op_private & ~OPpARG2_MASK)); /* barf on unknown flags */
2816
2817         parentop = topop;
2818         topop = cBINOPo->op_first;
2819         targetop = OpSIBLING(topop);
2820         if (!targetop) /* probably some sort of syntax error */
2821             return;
2822     }
2823     else if (   topop->op_type == OP_CONCAT
2824              && (topop->op_flags & OPf_STACKED)
2825              && (!(topop->op_private & OPpCONCAT_NESTED))
2826             )
2827     {
2828         /* expr .= ..... */
2829
2830         /* OPpTARGET_MY shouldn't be able to be set here. If it is,
2831          * decide what to do about it */
2832         assert(!(o->op_private & OPpTARGET_MY));
2833
2834         /* barf on unknown flags */
2835         assert(!(o->op_private & ~(OPpARG2_MASK|OPpTARGET_MY)));
2836         private_flags |= OPpMULTICONCAT_APPEND;
2837         targetop = cBINOPo->op_first;
2838         parentop = topop;
2839         topop    = OpSIBLING(targetop);
2840
2841         /* $x .= <FOO> gets optimised to rcatline instead */
2842         if (topop->op_type == OP_READLINE)
2843             return;
2844     }
2845
2846     if (targetop) {
2847         /* Can targetop (the LHS) if it's a padsv, be be optimised
2848          * away and use OPpTARGET_MY instead?
2849          */
2850         if (    (targetop->op_type == OP_PADSV)
2851             && !(targetop->op_private & OPpDEREF)
2852             && !(targetop->op_private & OPpPAD_STATE)
2853                /* we don't support 'my $x .= ...' */
2854             && (   o->op_type == OP_SASSIGN
2855                 || !(targetop->op_private & OPpLVAL_INTRO))
2856         )
2857             is_targable = TRUE;
2858     }
2859
2860     if (topop->op_type == OP_STRINGIFY) {
2861         if (topop->op_ppaddr != PL_ppaddr[OP_STRINGIFY])
2862             return;
2863         stringop = topop;
2864
2865         /* barf on unknown flags */
2866         assert(!(o->op_private & ~(OPpARG4_MASK|OPpTARGET_MY)));
2867
2868         if ((topop->op_private & OPpTARGET_MY)) {
2869             if (o->op_type == OP_SASSIGN)
2870                 return; /* can't have two assigns */
2871             targmyop = topop;
2872         }
2873
2874         private_flags |= OPpMULTICONCAT_STRINGIFY;
2875         parentop = topop;
2876         topop = cBINOPx(topop)->op_first;
2877         assert(OP_TYPE_IS_OR_WAS_NN(topop, OP_PUSHMARK));
2878         topop = OpSIBLING(topop);
2879     }
2880
2881     if (topop->op_type == OP_SPRINTF) {
2882         if (topop->op_ppaddr != PL_ppaddr[OP_SPRINTF])
2883             return;
2884         if (S_sprintf_is_multiconcatable(aTHX_ topop, &sprintf_info)) {
2885             nargs     = sprintf_info.nargs;
2886             total_len = sprintf_info.total_len;
2887             variant   = sprintf_info.variant;
2888             utf8      = sprintf_info.utf8;
2889             is_sprintf = TRUE;
2890             private_flags |= OPpMULTICONCAT_FAKE;
2891             toparg = argp;
2892             /* we have an sprintf op rather than a concat optree.
2893              * Skip most of the code below which is associated with
2894              * processing that optree. We also skip phase 2, determining
2895              * whether its cost effective to optimise, since for sprintf,
2896              * multiconcat is *always* faster */
2897             goto create_aux;
2898         }
2899         /* note that even if the sprintf itself isn't multiconcatable,
2900          * the expression as a whole may be, e.g. in
2901          *    $x .= sprintf("%d",...)
2902          * the sprintf op will be left as-is, but the concat/S op may
2903          * be upgraded to multiconcat
2904          */
2905     }
2906     else if (topop->op_type == OP_CONCAT) {
2907         if (topop->op_ppaddr != PL_ppaddr[OP_CONCAT])
2908             return;
2909
2910         if ((topop->op_private & OPpTARGET_MY)) {
2911             if (o->op_type == OP_SASSIGN || targmyop)
2912                 return; /* can't have two assigns */
2913             targmyop = topop;
2914         }
2915     }
2916
2917     /* Is it safe to convert a sassign/stringify/concat op into
2918      * a multiconcat? */
2919     assert((PL_opargs[OP_SASSIGN]   & OA_CLASS_MASK) == OA_BINOP);
2920     assert((PL_opargs[OP_CONCAT]    & OA_CLASS_MASK) == OA_BINOP);
2921     assert((PL_opargs[OP_STRINGIFY] & OA_CLASS_MASK) == OA_LISTOP);
2922     assert((PL_opargs[OP_SPRINTF]   & OA_CLASS_MASK) == OA_LISTOP);
2923     STATIC_ASSERT_STMT(   STRUCT_OFFSET(BINOP,    op_last)
2924                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2925     STATIC_ASSERT_STMT(   STRUCT_OFFSET(LISTOP,   op_last)
2926                        == STRUCT_OFFSET(UNOP_AUX, op_aux));
2927
2928     /* Now scan the down the tree looking for a series of
2929      * CONCAT/OPf_STACKED ops on the LHS (with the last one not
2930      * stacked). For example this tree:
2931      *
2932      *     |
2933      *   CONCAT/STACKED
2934      *     |
2935      *   CONCAT/STACKED -- EXPR5
2936      *     |
2937      *   CONCAT/STACKED -- EXPR4
2938      *     |
2939      *   CONCAT -- EXPR3
2940      *     |
2941      *   EXPR1  -- EXPR2
2942      *
2943      * corresponds to an expression like
2944      *
2945      *   (EXPR1 . EXPR2 . EXPR3 . EXPR4 . EXPR5)
2946      *
2947      * Record info about each EXPR in args[]: in particular, whether it is
2948      * a stringifiable OP_CONST and if so what the const sv is.
2949      *
2950      * The reason why the last concat can't be STACKED is the difference
2951      * between
2952      *
2953      *    ((($a .= $a) .= $a) .= $a) .= $a
2954      *
2955      * and
2956      *    $a . $a . $a . $a . $a
2957      *
2958      * The main difference between the optrees for those two constructs
2959      * is the presence of the last STACKED. As well as modifying $a,
2960      * the former sees the changed $a between each concat, so if $s is
2961      * initially 'a', the first returns 'a' x 16, while the latter returns
2962      * 'a' x 5. And pp_multiconcat can't handle that kind of thing.
2963      */
2964
2965     kid = topop;
2966
2967     for (;;) {
2968         OP *argop;
2969         SV *sv;
2970         bool last = FALSE;
2971
2972         if (    kid->op_type == OP_CONCAT
2973             && !kid_is_last
2974         ) {
2975             OP *k1, *k2;
2976             k1 = cUNOPx(kid)->op_first;
2977             k2 = OpSIBLING(k1);
2978             /* shouldn't happen except maybe after compile err? */
2979             if (!k2)
2980                 return;
2981
2982             /* avoid turning (A . B . ($lex = C) ...)  into  (A . B . C ...) */
2983             if (kid->op_private & OPpTARGET_MY)
2984                 kid_is_last = TRUE;
2985
2986             stacked_last = (kid->op_flags & OPf_STACKED);
2987             if (!stacked_last)
2988                 kid_is_last = TRUE;
2989
2990             kid   = k1;
2991             argop = k2;
2992         }
2993         else {
2994             argop = kid;
2995             last = TRUE;
2996         }
2997
2998         if (   nargs + nadjconst  >  PERL_MULTICONCAT_MAXARG        - 2
2999             || (argp - args + 1)  > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
3000         {
3001             /* At least two spare slots are needed to decompose both
3002              * concat args. If there are no slots left, continue to
3003              * examine the rest of the optree, but don't push new values
3004              * on args[]. If the optree as a whole is legal for conversion
3005              * (in particular that the last concat isn't STACKED), then
3006              * the first PERL_MULTICONCAT_MAXARG elements of the optree
3007              * can be converted into an OP_MULTICONCAT now, with the first
3008              * child of that op being the remainder of the optree -
3009              * which may itself later be converted to a multiconcat op
3010              * too.
3011              */
3012             if (last) {
3013                 /* the last arg is the rest of the optree */
3014                 argp++->p = NULL;
3015                 nargs++;
3016             }
3017         }
3018         else if (   argop->op_type == OP_CONST
3019             && ((sv = cSVOPx_sv(argop)))
3020             /* defer stringification until runtime of 'constant'
3021              * things that might stringify variantly, e.g. the radix
3022              * point of NVs, or overloaded RVs */
3023             && (SvPOK(sv) || SvIOK(sv))
3024             && (!SvGMAGICAL(sv))
3025         ) {
3026             argp++->p = sv;
3027             utf8   |= cBOOL(SvUTF8(sv));
3028             nconst++;
3029             if (prev_was_const)
3030                 /* this const may be demoted back to a plain arg later;
3031                  * make sure we have enough arg slots left */
3032                 nadjconst++;
3033             prev_was_const = !prev_was_const;
3034         }
3035         else {
3036             argp++->p = NULL;
3037             nargs++;
3038             prev_was_const = FALSE;
3039         }
3040
3041         if (last)
3042             break;
3043     }
3044
3045     toparg = argp - 1;
3046
3047     if (stacked_last)
3048         return; /* we don't support ((A.=B).=C)...) */
3049
3050     /* look for two adjacent consts and don't fold them together:
3051      *     $o . "a" . "b"
3052      * should do
3053      *     $o->concat("a")->concat("b")
3054      * rather than
3055      *     $o->concat("ab")
3056      * (but $o .=  "a" . "b" should still fold)
3057      */
3058     {
3059         bool seen_nonconst = FALSE;
3060         for (argp = toparg; argp >= args; argp--) {
3061             if (argp->p == NULL) {
3062                 seen_nonconst = TRUE;
3063                 continue;
3064             }
3065             if (!seen_nonconst)
3066                 continue;
3067             if (argp[1].p) {
3068                 /* both previous and current arg were constants;
3069                  * leave the current OP_CONST as-is */
3070                 argp->p = NULL;
3071                 nconst--;
3072                 nargs++;
3073             }
3074         }
3075     }
3076
3077     /* -----------------------------------------------------------------
3078      * Phase 2:
3079      *
3080      * At this point we have determined that the optree *can* be converted
3081      * into a multiconcat. Having gathered all the evidence, we now decide
3082      * whether it *should*.
3083      */
3084
3085
3086     /* we need at least one concat action, e.g.:
3087      *
3088      *  Y . Z
3089      *  X = Y . Z
3090      *  X .= Y
3091      *
3092      * otherwise we could be doing something like $x = "foo", which
3093      * if treated as as a concat, would fail to COW.
3094      */
3095     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 2)
3096         return;
3097
3098     /* Benchmarking seems to indicate that we gain if:
3099      * * we optimise at least two actions into a single multiconcat
3100      *    (e.g concat+concat, sassign+concat);
3101      * * or if we can eliminate at least 1 OP_CONST;
3102      * * or if we can eliminate a padsv via OPpTARGET_MY
3103      */
3104
3105     if (
3106            /* eliminated at least one OP_CONST */
3107            nconst >= 1
3108            /* eliminated an OP_SASSIGN */
3109         || o->op_type == OP_SASSIGN
3110            /* eliminated an OP_PADSV */
3111         || (!targmyop && is_targable)
3112     )
3113         /* definitely a net gain to optimise */
3114         goto optimise;
3115
3116     /* ... if not, what else? */
3117
3118     /* special-case '$lex1 = expr . $lex1' (where expr isn't lex1):
3119      * multiconcat is faster (due to not creating a temporary copy of
3120      * $lex1), whereas for a general $lex1 = $lex2 . $lex3, concat is
3121      * faster.
3122      */
3123     if (   nconst == 0
3124          && nargs == 2
3125          && targmyop
3126          && topop->op_type == OP_CONCAT
3127     ) {
3128         PADOFFSET t = targmyop->op_targ;
3129         OP *k1 = cBINOPx(topop)->op_first;
3130         OP *k2 = cBINOPx(topop)->op_last;
3131         if (   k2->op_type == OP_PADSV
3132             && k2->op_targ == t
3133             && (   k1->op_type != OP_PADSV
3134                 || k1->op_targ != t)
3135         )
3136             goto optimise;
3137     }
3138
3139     /* need at least two concats */
3140     if (nargs + nconst + cBOOL(private_flags & OPpMULTICONCAT_APPEND) < 3)
3141         return;
3142
3143
3144
3145     /* -----------------------------------------------------------------
3146      * Phase 3:
3147      *
3148      * At this point the optree has been verified as ok to be optimised
3149      * into an OP_MULTICONCAT. Now start changing things.
3150      */
3151
3152    optimise:
3153
3154     /* stringify all const args and determine utf8ness */
3155
3156     variant = 0;
3157     for (argp = args; argp <= toparg; argp++) {
3158         SV *sv = (SV*)argp->p;
3159         if (!sv)
3160             continue; /* not a const op */
3161         if (utf8 && !SvUTF8(sv))
3162             sv_utf8_upgrade_nomg(sv);
3163         argp->p = SvPV_nomg(sv, argp->len);
3164         total_len += argp->len;
3165         
3166         /* see if any strings would grow if converted to utf8 */
3167         if (!utf8) {
3168             variant += variant_under_utf8_count((U8 *) argp->p,
3169                                                 (U8 *) argp->p + argp->len);
3170         }
3171     }
3172
3173     /* create and populate aux struct */
3174
3175   create_aux:
3176
3177     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3178                     sizeof(UNOP_AUX_item)
3179                     *  (
3180                            PERL_MULTICONCAT_HEADER_SIZE
3181                          + ((nargs + 1) * (variant ? 2 : 1))
3182                         )
3183                     );
3184     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3185
3186     /* Extract all the non-const expressions from the concat tree then
3187      * dispose of the old tree, e.g. convert the tree from this:
3188      *
3189      *  o => SASSIGN
3190      *         |
3191      *       STRINGIFY   -- TARGET
3192      *         |
3193      *       ex-PUSHMARK -- CONCAT
3194      *                        |
3195      *                      CONCAT -- EXPR5
3196      *                        |
3197      *                      CONCAT -- EXPR4
3198      *                        |
3199      *                      CONCAT -- EXPR3
3200      *                        |
3201      *                      EXPR1  -- EXPR2
3202      *
3203      *
3204      * to:
3205      *
3206      *  o => MULTICONCAT
3207      *         |
3208      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3209      *
3210      * except that if EXPRi is an OP_CONST, it's discarded.
3211      *
3212      * During the conversion process, EXPR ops are stripped from the tree
3213      * and unshifted onto o. Finally, any of o's remaining original
3214      * childen are discarded and o is converted into an OP_MULTICONCAT.
3215      *
3216      * In this middle of this, o may contain both: unshifted args on the
3217      * left, and some remaining original args on the right. lastkidop
3218      * is set to point to the right-most unshifted arg to delineate
3219      * between the two sets.
3220      */
3221
3222
3223     if (is_sprintf) {
3224         /* create a copy of the format with the %'s removed, and record
3225          * the sizes of the const string segments in the aux struct */
3226         char *q, *oldq;
3227         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3228
3229         p    = sprintf_info.start;
3230         q    = const_str;
3231         oldq = q;
3232         for (; p < sprintf_info.end; p++) {
3233             if (*p == '%') {
3234                 p++;
3235                 if (*p != '%') {
3236                     (lenp++)->ssize = q - oldq;
3237                     oldq = q;
3238                     continue;
3239                 }
3240             }
3241             *q++ = *p;
3242         }
3243         lenp->ssize = q - oldq;
3244         assert((STRLEN)(q - const_str) == total_len);
3245
3246         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3247          * may or may not be topop) The pushmark and const ops need to be
3248          * kept in case they're an op_next entry point.
3249          */
3250         lastkidop = cLISTOPx(topop)->op_last;
3251         kid = cUNOPx(topop)->op_first; /* pushmark */
3252         op_null(kid);
3253         op_null(OpSIBLING(kid));       /* const */
3254         if (o != topop) {
3255             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3256             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3257             lastkidop->op_next = o;
3258         }
3259     }
3260     else {
3261         p = const_str;
3262         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3263
3264         lenp->ssize = -1;
3265
3266         /* Concatenate all const strings into const_str.
3267          * Note that args[] contains the RHS args in reverse order, so
3268          * we scan args[] from top to bottom to get constant strings
3269          * in L-R order
3270          */
3271         for (argp = toparg; argp >= args; argp--) {
3272             if (!argp->p)
3273                 /* not a const op */
3274                 (++lenp)->ssize = -1;
3275             else {
3276                 STRLEN l = argp->len;
3277                 Copy(argp->p, p, l, char);
3278                 p += l;
3279                 if (lenp->ssize == -1)
3280                     lenp->ssize = l;
3281                 else
3282                     lenp->ssize += l;
3283             }
3284         }
3285
3286         kid = topop;
3287         nextop = o;
3288         lastkidop = NULL;
3289
3290         for (argp = args; argp <= toparg; argp++) {
3291             /* only keep non-const args, except keep the first-in-next-chain
3292              * arg no matter what it is (but nulled if OP_CONST), because it
3293              * may be the entry point to this subtree from the previous
3294              * op_next.
3295              */
3296             bool last = (argp == toparg);
3297             OP *prev;
3298
3299             /* set prev to the sibling *before* the arg to be cut out,
3300              * e.g. when cutting EXPR:
3301              *
3302              *         |
3303              * kid=  CONCAT
3304              *         |
3305              * prev= CONCAT -- EXPR
3306              *         |
3307              */
3308             if (argp == args && kid->op_type != OP_CONCAT) {
3309                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3310                  * so the expression to be cut isn't kid->op_last but
3311                  * kid itself */
3312                 OP *o1, *o2;
3313                 /* find the op before kid */
3314                 o1 = NULL;
3315                 o2 = cUNOPx(parentop)->op_first;
3316                 while (o2 && o2 != kid) {
3317                     o1 = o2;
3318                     o2 = OpSIBLING(o2);
3319                 }
3320                 assert(o2 == kid);
3321                 prev = o1;
3322                 kid  = parentop;
3323             }
3324             else if (kid == o && lastkidop)
3325                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3326             else
3327                 prev = last ? NULL : cUNOPx(kid)->op_first;
3328
3329             if (!argp->p || last) {
3330                 /* cut RH op */
3331                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3332                 /* and unshift to front of o */
3333                 op_sibling_splice(o, NULL, 0, aop);
3334                 /* record the right-most op added to o: later we will
3335                  * free anything to the right of it */
3336                 if (!lastkidop)
3337                     lastkidop = aop;
3338                 aop->op_next = nextop;
3339                 if (last) {
3340                     if (argp->p)
3341                         /* null the const at start of op_next chain */
3342                         op_null(aop);
3343                 }
3344                 else if (prev)
3345                     nextop = prev->op_next;
3346             }
3347
3348             /* the last two arguments are both attached to the same concat op */
3349             if (argp < toparg - 1)
3350                 kid = prev;
3351         }
3352     }
3353
3354     /* Populate the aux struct */
3355
3356     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3357     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3358     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3359     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3360     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3361
3362     /* if variant > 0, calculate a variant const string and lengths where
3363      * the utf8 version of the string will take 'variant' more bytes than
3364      * the plain one. */
3365
3366     if (variant) {
3367         char              *p = const_str;
3368         STRLEN          ulen = total_len + variant;
3369         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3370         UNOP_AUX_item *ulens = lens + (nargs + 1);
3371         char             *up = (char*)PerlMemShared_malloc(ulen);
3372         SSize_t            n;
3373
3374         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3375         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3376
3377         for (n = 0; n < (nargs + 1); n++) {
3378             SSize_t i;
3379             char * orig_up = up;
3380             for (i = (lens++)->ssize; i > 0; i--) {
3381                 U8 c = *p++;
3382                 append_utf8_from_native_byte(c, (U8**)&up);
3383             }
3384             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3385         }
3386     }
3387
3388     if (stringop) {
3389         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3390          * that op's first child - an ex-PUSHMARK - because the op_next of
3391          * the previous op may point to it (i.e. it's the entry point for
3392          * the o optree)
3393          */
3394         OP *pmop =
3395             (stringop == o)
3396                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3397                 : op_sibling_splice(stringop, NULL, 1, NULL);
3398         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3399         op_sibling_splice(o, NULL, 0, pmop);
3400         if (!lastkidop)
3401             lastkidop = pmop;
3402     }
3403
3404     /* Optimise 
3405      *    target  = A.B.C...
3406      *    target .= A.B.C...
3407      */
3408
3409     if (targetop) {
3410         assert(!targmyop);
3411
3412         if (o->op_type == OP_SASSIGN) {
3413             /* Move the target subtree from being the last of o's children
3414              * to being the last of o's preserved children.
3415              * Note the difference between 'target = ...' and 'target .= ...':
3416              * for the former, target is executed last; for the latter,
3417              * first.
3418              */
3419             kid = OpSIBLING(lastkidop);
3420             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3421             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3422             lastkidop->op_next = kid->op_next;
3423             lastkidop = targetop;
3424         }
3425         else {
3426             /* Move the target subtree from being the first of o's
3427              * original children to being the first of *all* o's children.
3428              */
3429             if (lastkidop) {
3430                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3431                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3432             }
3433             else {
3434                 /* if the RHS of .= doesn't contain a concat (e.g.
3435                  * $x .= "foo"), it gets missed by the "strip ops from the
3436                  * tree and add to o" loop earlier */
3437                 assert(topop->op_type != OP_CONCAT);
3438                 if (stringop) {
3439                     /* in e.g. $x .= "$y", move the $y expression
3440                      * from being a child of OP_STRINGIFY to being the
3441                      * second child of the OP_CONCAT
3442                      */
3443                     assert(cUNOPx(stringop)->op_first == topop);
3444                     op_sibling_splice(stringop, NULL, 1, NULL);
3445                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3446                 }
3447                 assert(topop == OpSIBLING(cBINOPo->op_first));
3448                 if (toparg->p)
3449                     op_null(topop);
3450                 lastkidop = topop;
3451             }
3452         }
3453
3454         if (is_targable) {
3455             /* optimise
3456              *  my $lex  = A.B.C...
3457              *     $lex  = A.B.C...
3458              *     $lex .= A.B.C...
3459              * The original padsv op is kept but nulled in case it's the
3460              * entry point for the optree (which it will be for
3461              * '$lex .=  ... '
3462              */
3463             private_flags |= OPpTARGET_MY;
3464             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3465             o->op_targ = targetop->op_targ;
3466             targetop->op_targ = 0;
3467             op_null(targetop);
3468         }
3469         else
3470             flags |= OPf_STACKED;
3471     }
3472     else if (targmyop) {
3473         private_flags |= OPpTARGET_MY;
3474         if (o != targmyop) {
3475             o->op_targ = targmyop->op_targ;
3476             targmyop->op_targ = 0;
3477         }
3478     }
3479
3480     /* detach the emaciated husk of the sprintf/concat optree and free it */
3481     for (;;) {
3482         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3483         if (!kid)
3484             break;
3485         op_free(kid);
3486     }
3487
3488     /* and convert o into a multiconcat */
3489
3490     o->op_flags        = (flags|OPf_KIDS|stacked_last
3491                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3492     o->op_private      = private_flags;
3493     o->op_type         = OP_MULTICONCAT;
3494     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3495     cUNOP_AUXo->op_aux = aux;
3496 }
3497
3498
3499 /* do all the final processing on an optree (e.g. running the peephole
3500  * optimiser on it), then attach it to cv (if cv is non-null)
3501  */
3502
3503 static void
3504 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3505 {
3506     OP **startp;
3507
3508     /* XXX for some reason, evals, require and main optrees are
3509      * never attached to their CV; instead they just hang off
3510      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3511      * and get manually freed when appropriate */
3512     if (cv)
3513         startp = &CvSTART(cv);
3514     else
3515         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3516
3517     *startp = start;
3518     optree->op_private |= OPpREFCOUNTED;
3519     OpREFCNT_set(optree, 1);
3520     optimize_optree(optree);
3521     CALL_PEEP(*startp);
3522     finalize_optree(optree);
3523     S_prune_chain_head(startp);
3524
3525     if (cv) {
3526         /* now that optimizer has done its work, adjust pad values */
3527         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3528                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3529     }
3530 }
3531
3532
3533 /*
3534 =for apidoc optimize_optree
3535
3536 This function applies some optimisations to the optree in top-down order.
3537 It is called before the peephole optimizer, which processes ops in
3538 execution order. Note that finalize_optree() also does a top-down scan,
3539 but is called *after* the peephole optimizer.
3540
3541 =cut
3542 */
3543
3544 void
3545 Perl_optimize_optree(pTHX_ OP* o)
3546 {
3547     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3548
3549     ENTER;
3550     SAVEVPTR(PL_curcop);
3551
3552     optimize_op(o);
3553
3554     LEAVE;
3555 }
3556
3557
3558 /* helper for optimize_optree() which optimises one op then recurses
3559  * to optimise any children.
3560  */
3561
3562 STATIC void
3563 S_optimize_op(pTHX_ OP* o)
3564 {
3565     OP *top_op = o;
3566
3567     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3568
3569     while (1) {
3570         OP * next_kid = NULL;
3571
3572         assert(o->op_type != OP_FREED);
3573
3574         switch (o->op_type) {
3575         case OP_NEXTSTATE:
3576         case OP_DBSTATE:
3577             PL_curcop = ((COP*)o);              /* for warnings */
3578             break;
3579
3580
3581         case OP_CONCAT:
3582         case OP_SASSIGN:
3583         case OP_STRINGIFY:
3584         case OP_SPRINTF:
3585             S_maybe_multiconcat(aTHX_ o);
3586             break;
3587
3588         case OP_SUBST:
3589             if (cPMOPo->op_pmreplrootu.op_pmreplroot) {
3590                 /* we can't assume that op_pmreplroot->op_sibparent == o
3591                  * and that it is thus possible to walk back up the tree
3592                  * past op_pmreplroot. So, although we try to avoid
3593                  * recursing through op trees, do it here. After all,
3594                  * there are unlikely to be many nested s///e's within
3595                  * the replacement part of a s///e.
3596                  */
3597                 optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3598             }
3599             break;
3600
3601         default:
3602             break;
3603         }
3604
3605         if (o->op_flags & OPf_KIDS)
3606             next_kid = cUNOPo->op_first;
3607
3608         /* if a kid hasn't been nominated to process, continue with the
3609          * next sibling, or if no siblings left, go back to the parent's
3610          * siblings and so on
3611          */
3612         while (!next_kid) {
3613             if (o == top_op)
3614                 return; /* at top; no parents/siblings to try */
3615             if (OpHAS_SIBLING(o))
3616                 next_kid = o->op_sibparent;
3617             else
3618                 o = o->op_sibparent; /*try parent's next sibling */
3619         }
3620
3621       /* this label not yet used. Goto here if any code above sets
3622        * next-kid
3623        get_next_op:
3624        */
3625         o = next_kid;
3626     }
3627 }
3628
3629
3630 /*
3631 =for apidoc finalize_optree
3632
3633 This function finalizes the optree.  Should be called directly after
3634 the complete optree is built.  It does some additional
3635 checking which can't be done in the normal C<ck_>xxx functions and makes
3636 the tree thread-safe.
3637
3638 =cut
3639 */
3640 void
3641 Perl_finalize_optree(pTHX_ OP* o)
3642 {
3643     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3644
3645     ENTER;
3646     SAVEVPTR(PL_curcop);
3647
3648     finalize_op(o);
3649
3650     LEAVE;
3651 }
3652
3653 #ifdef USE_ITHREADS
3654 /* Relocate sv to the pad for thread safety.
3655  * Despite being a "constant", the SV is written to,
3656  * for reference counts, sv_upgrade() etc. */
3657 PERL_STATIC_INLINE void
3658 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3659 {
3660     PADOFFSET ix;
3661     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3662     if (!*svp) return;
3663     ix = pad_alloc(OP_CONST, SVf_READONLY);
3664     SvREFCNT_dec(PAD_SVl(ix));
3665     PAD_SETSV(ix, *svp);
3666     /* XXX I don't know how this isn't readonly already. */
3667     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3668     *svp = NULL;
3669     *targp = ix;
3670 }
3671 #endif
3672
3673 /*
3674 =for apidoc traverse_op_tree
3675
3676 Return the next op in a depth-first traversal of the op tree,
3677 returning NULL when the traversal is complete.
3678
3679 The initial call must supply the root of the tree as both top and o.
3680
3681 For now it's static, but it may be exposed to the API in the future.
3682
3683 =cut
3684 */
3685
3686 STATIC OP*
3687 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3688     OP *sib;
3689
3690     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3691
3692     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3693         return cUNOPo->op_first;
3694     }
3695     else if ((sib = OpSIBLING(o))) {
3696         return sib;
3697     }
3698     else {
3699         OP *parent = o->op_sibparent;
3700         assert(!(o->op_moresib));
3701         while (parent && parent != top) {
3702             OP *sib = OpSIBLING(parent);
3703             if (sib)
3704                 return sib;
3705             parent = parent->op_sibparent;
3706         }
3707
3708         return NULL;
3709     }
3710 }
3711
3712 STATIC void
3713 S_finalize_op(pTHX_ OP* o)
3714 {
3715     OP * const top = o;
3716     PERL_ARGS_ASSERT_FINALIZE_OP;
3717
3718     do {
3719         assert(o->op_type != OP_FREED);
3720
3721         switch (o->op_type) {
3722         case OP_NEXTSTATE:
3723         case OP_DBSTATE:
3724             PL_curcop = ((COP*)o);              /* for warnings */
3725             break;
3726         case OP_EXEC:
3727             if (OpHAS_SIBLING(o)) {
3728                 OP *sib = OpSIBLING(o);
3729                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3730                     && ckWARN(WARN_EXEC)
3731                     && OpHAS_SIBLING(sib))
3732                 {
3733                     const OPCODE type = OpSIBLING(sib)->op_type;
3734                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3735                         const line_t oldline = CopLINE(PL_curcop);
3736                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3737                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3738                             "Statement unlikely to be reached");
3739                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3740                             "\t(Maybe you meant system() when you said exec()?)\n");
3741                         CopLINE_set(PL_curcop, oldline);
3742                     }
3743                 }
3744             }
3745             break;
3746
3747         case OP_GV:
3748             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3749                 GV * const gv = cGVOPo_gv;
3750                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3751                     /* XXX could check prototype here instead of just carping */
3752                     SV * const sv = sv_newmortal();
3753                     gv_efullname3(sv, gv, NULL);
3754                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3755                                 "%" SVf "() called too early to check prototype",
3756                                 SVfARG(sv));
3757                 }
3758             }
3759             break;
3760
3761         case OP_CONST:
3762             if (cSVOPo->op_private & OPpCONST_STRICT)
3763                 no_bareword_allowed(o);
3764 #ifdef USE_ITHREADS
3765             /* FALLTHROUGH */
3766         case OP_HINTSEVAL:
3767             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3768 #endif
3769             break;
3770
3771 #ifdef USE_ITHREADS
3772             /* Relocate all the METHOP's SVs to the pad for thread safety. */
3773         case OP_METHOD_NAMED:
3774         case OP_METHOD_SUPER:
3775         case OP_METHOD_REDIR:
3776         case OP_METHOD_REDIR_SUPER:
3777             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3778             break;
3779 #endif
3780
3781         case OP_HELEM: {
3782             UNOP *rop;
3783             SVOP *key_op;
3784             OP *kid;
3785
3786             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3787                 break;
3788
3789             rop = (UNOP*)((BINOP*)o)->op_first;
3790
3791             goto check_keys;
3792
3793             case OP_HSLICE:
3794                 S_scalar_slice_warning(aTHX_ o);
3795                 /* FALLTHROUGH */
3796
3797             case OP_KVHSLICE:
3798                 kid = OpSIBLING(cLISTOPo->op_first);
3799             if (/* I bet there's always a pushmark... */
3800                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3801                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3802             {
3803                 break;
3804             }
3805
3806             key_op = (SVOP*)(kid->op_type == OP_CONST
3807                              ? kid
3808                              : OpSIBLING(kLISTOP->op_first));
3809
3810             rop = (UNOP*)((LISTOP*)o)->op_last;
3811
3812         check_keys:
3813             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3814                 rop = NULL;
3815             S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3816             break;
3817         }
3818         case OP_NULL:
3819             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3820                 break;
3821             /* FALLTHROUGH */
3822         case OP_ASLICE:
3823             S_scalar_slice_warning(aTHX_ o);
3824             break;
3825
3826         case OP_SUBST: {
3827             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3828                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3829             break;
3830         }
3831         default:
3832             break;
3833         }
3834
3835 #ifdef DEBUGGING
3836         if (o->op_flags & OPf_KIDS) {
3837             OP *kid;
3838
3839             /* check that op_last points to the last sibling, and that
3840              * the last op_sibling/op_sibparent field points back to the
3841              * parent, and that the only ops with KIDS are those which are
3842              * entitled to them */
3843             U32 type = o->op_type;
3844             U32 family;
3845             bool has_last;
3846
3847             if (type == OP_NULL) {
3848                 type = o->op_targ;
3849                 /* ck_glob creates a null UNOP with ex-type GLOB
3850                  * (which is a list op. So pretend it wasn't a listop */
3851                 if (type == OP_GLOB)
3852                     type = OP_NULL;
3853             }
3854             family = PL_opargs[type] & OA_CLASS_MASK;
3855
3856             has_last = (   family == OA_BINOP
3857                         || family == OA_LISTOP
3858                         || family == OA_PMOP
3859                         || family == OA_LOOP
3860                        );
3861             assert(  has_last /* has op_first and op_last, or ...
3862                   ... has (or may have) op_first: */
3863                   || family == OA_UNOP
3864                   || family == OA_UNOP_AUX
3865                   || family == OA_LOGOP
3866                   || family == OA_BASEOP_OR_UNOP
3867                   || family == OA_FILESTATOP
3868                   || family == OA_LOOPEXOP
3869                   || family == OA_METHOP
3870                   || type == OP_CUSTOM
3871                   || type == OP_NULL /* new_logop does this */
3872                   );
3873
3874             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3875                 if (!OpHAS_SIBLING(kid)) {
3876                     if (has_last)
3877                         assert(kid == cLISTOPo->op_last);
3878                     assert(kid->op_sibparent == o);
3879                 }
3880             }
3881         }
3882 #endif
3883     } while (( o = traverse_op_tree(top, o)) != NULL);
3884 }
3885
3886 /*
3887 =for apidoc op_lvalue
3888
3889 Propagate lvalue ("modifiable") context to an op and its children.
3890 C<type> represents the context type, roughly based on the type of op that
3891 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3892 because it has no op type of its own (it is signalled by a flag on
3893 the lvalue op).
3894
3895 This function detects things that can't be modified, such as C<$x+1>, and
3896 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3897 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3898
3899 It also flags things that need to behave specially in an lvalue context,
3900 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3901
3902 =cut
3903 */
3904
3905 static void
3906 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3907 {
3908     CV *cv = PL_compcv;
3909     PadnameLVALUE_on(pn);
3910     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3911         cv = CvOUTSIDE(cv);
3912         /* RT #127786: cv can be NULL due to an eval within the DB package
3913          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3914          * unless they contain an eval, but calling eval within DB
3915          * pretends the eval was done in the caller's scope.
3916          */
3917         if (!cv)
3918             break;
3919         assert(CvPADLIST(cv));
3920         pn =
3921            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3922         assert(PadnameLEN(pn));
3923         PadnameLVALUE_on(pn);
3924     }
3925 }
3926
3927 static bool
3928 S_vivifies(const OPCODE type)
3929 {
3930     switch(type) {
3931     case OP_RV2AV:     case   OP_ASLICE:
3932     case OP_RV2HV:     case OP_KVASLICE:
3933     case OP_RV2SV:     case   OP_HSLICE:
3934     case OP_AELEMFAST: case OP_KVHSLICE:
3935     case OP_HELEM:
3936     case OP_AELEM:
3937         return 1;
3938     }
3939     return 0;
3940 }
3941
3942 static void
3943 S_lvref(pTHX_ OP *o, I32 type)
3944 {
3945     dVAR;
3946     OP *kid;
3947     switch (o->op_type) {
3948     case OP_COND_EXPR:
3949         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3950              kid = OpSIBLING(kid))
3951             S_lvref(aTHX_ kid, type);
3952         /* FALLTHROUGH */
3953     case OP_PUSHMARK:
3954         return;
3955     case OP_RV2AV:
3956         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3957         o->op_flags |= OPf_STACKED;
3958         if (o->op_flags & OPf_PARENS) {
3959             if (o->op_private & OPpLVAL_INTRO) {
3960                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3961                       "localized parenthesized array in list assignment"));
3962                 return;
3963             }
3964           slurpy:
3965             OpTYPE_set(o, OP_LVAVREF);
3966             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3967             o->op_flags |= OPf_MOD|OPf_REF;
3968             return;
3969         }
3970         o->op_private |= OPpLVREF_AV;
3971         goto checkgv;
3972     case OP_RV2CV:
3973         kid = cUNOPo->op_first;
3974         if (kid->op_type == OP_NULL)
3975             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3976                 ->op_first;
3977         o->op_private = OPpLVREF_CV;
3978         if (kid->op_type == OP_GV)
3979             o->op_flags |= OPf_STACKED;
3980         else if (kid->op_type == OP_PADCV) {
3981             o->op_targ = kid->op_targ;
3982             kid->op_targ = 0;
3983             op_free(cUNOPo->op_first);
3984             cUNOPo->op_first = NULL;
3985             o->op_flags &=~ OPf_KIDS;
3986         }
3987         else goto badref;
3988         break;
3989     case OP_RV2HV:
3990         if (o->op_flags & OPf_PARENS) {
3991           parenhash:
3992             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3993                                  "parenthesized hash in list assignment"));
3994                 return;
3995         }
3996         o->op_private |= OPpLVREF_HV;
3997         /* FALLTHROUGH */
3998     case OP_RV2SV:
3999       checkgv:
4000         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
4001         o->op_flags |= OPf_STACKED;
4002         break;
4003     case OP_PADHV:
4004         if (o->op_flags & OPf_PARENS) goto parenhash;
4005         o->op_private |= OPpLVREF_HV;
4006         /* FALLTHROUGH */
4007     case OP_PADSV:
4008         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4009         break;
4010     case OP_PADAV:
4011         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
4012         if (o->op_flags & OPf_PARENS) goto slurpy;
4013         o->op_private |= OPpLVREF_AV;
4014         break;
4015     case OP_AELEM:
4016     case OP_HELEM:
4017         o->op_private |= OPpLVREF_ELEM;
4018         o->op_flags   |= OPf_STACKED;
4019         break;
4020     case OP_ASLICE:
4021     case OP_HSLICE:
4022         OpTYPE_set(o, OP_LVREFSLICE);
4023         o->op_private &= OPpLVAL_INTRO;
4024         return;
4025     case OP_NULL:
4026         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4027             goto badref;
4028         else if (!(o->op_flags & OPf_KIDS))
4029             return;
4030         if (o->op_targ != OP_LIST) {
4031             S_lvref(aTHX_ cBINOPo->op_first, type);
4032             return;
4033         }
4034         /* FALLTHROUGH */
4035     case OP_LIST:
4036         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
4037             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
4038             S_lvref(aTHX_ kid, type);
4039         }
4040         return;
4041     case OP_STUB:
4042         if (o->op_flags & OPf_PARENS)
4043             return;
4044         /* FALLTHROUGH */
4045     default:
4046       badref:
4047         /* diag_listed_as: Can't modify reference to %s in %s assignment */
4048         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
4049                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
4050                       ? "do block"
4051                       : OP_DESC(o),
4052                      PL_op_desc[type]));
4053         return;
4054     }
4055     OpTYPE_set(o, OP_LVREF);
4056     o->op_private &=
4057         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
4058     if (type == OP_ENTERLOOP)
4059         o->op_private |= OPpLVREF_ITER;
4060 }
4061
4062 PERL_STATIC_INLINE bool
4063 S_potential_mod_type(I32 type)
4064 {
4065     /* Types that only potentially result in modification.  */
4066     return type == OP_GREPSTART || type == OP_ENTERSUB
4067         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
4068 }
4069
4070 OP *
4071 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
4072 {
4073     dVAR;
4074     OP *kid;
4075     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
4076     int localize = -1;
4077
4078     if (!o || (PL_parser && PL_parser->error_count))
4079         return o;
4080
4081     if ((o->op_private & OPpTARGET_MY)
4082         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
4083     {
4084         return o;
4085     }
4086
4087     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
4088
4089     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4090
4091     switch (o->op_type) {
4092     case OP_UNDEF:
4093         PL_modcount++;
4094         return o;
4095     case OP_STUB:
4096         if ((o->op_flags & OPf_PARENS))
4097             break;
4098         goto nomod;
4099     case OP_ENTERSUB:
4100         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4101             !(o->op_flags & OPf_STACKED)) {
4102             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
4103             assert(cUNOPo->op_first->op_type == OP_NULL);
4104             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4105             break;
4106         }
4107         else {                          /* lvalue subroutine call */
4108             o->op_private |= OPpLVAL_INTRO;
4109             PL_modcount = RETURN_UNLIMITED_NUMBER;
4110             if (S_potential_mod_type(type)) {
4111                 o->op_private |= OPpENTERSUB_INARGS;
4112                 break;
4113             }
4114             else {                      /* Compile-time error message: */
4115                 OP *kid = cUNOPo->op_first;
4116                 CV *cv;
4117                 GV *gv;
4118                 SV *namesv;
4119
4120                 if (kid->op_type != OP_PUSHMARK) {
4121                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4122                         Perl_croak(aTHX_
4123                                 "panic: unexpected lvalue entersub "
4124                                 "args: type/targ %ld:%" UVuf,
4125                                 (long)kid->op_type, (UV)kid->op_targ);
4126                     kid = kLISTOP->op_first;
4127                 }
4128                 while (OpHAS_SIBLING(kid))
4129                     kid = OpSIBLING(kid);
4130                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4131                     break;      /* Postpone until runtime */
4132                 }
4133
4134                 kid = kUNOP->op_first;
4135                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4136                     kid = kUNOP->op_first;
4137                 if (kid->op_type == OP_NULL)
4138                     Perl_croak(aTHX_
4139                                "Unexpected constant lvalue entersub "
4140                                "entry via type/targ %ld:%" UVuf,
4141                                (long)kid->op_type, (UV)kid->op_targ);
4142                 if (kid->op_type != OP_GV) {
4143                     break;
4144                 }
4145
4146                 gv = kGVOP_gv;
4147                 cv = isGV(gv)
4148                     ? GvCV(gv)
4149                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4150                         ? MUTABLE_CV(SvRV(gv))
4151                         : NULL;
4152                 if (!cv)
4153                     break;
4154                 if (CvLVALUE(cv))
4155                     break;
4156                 if (flags & OP_LVALUE_NO_CROAK)
4157                     return NULL;
4158
4159                 namesv = cv_name(cv, NULL, 0);
4160                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4161                                      "subroutine call of &%" SVf " in %s",
4162                                      SVfARG(namesv), PL_op_desc[type]),
4163                            SvUTF8(namesv));
4164                 return o;
4165             }
4166         }
4167         /* FALLTHROUGH */
4168     default:
4169       nomod:
4170         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4171         /* grep, foreach, subcalls, refgen */
4172         if (S_potential_mod_type(type))
4173             break;
4174         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4175                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4176                       ? "do block"
4177                       : OP_DESC(o)),
4178                      type ? PL_op_desc[type] : "local"));
4179         return o;
4180
4181     case OP_PREINC:
4182     case OP_PREDEC:
4183     case OP_POW:
4184     case OP_MULTIPLY:
4185     case OP_DIVIDE:
4186     case OP_MODULO:
4187     case OP_ADD:
4188     case OP_SUBTRACT:
4189     case OP_CONCAT:
4190     case OP_LEFT_SHIFT:
4191     case OP_RIGHT_SHIFT:
4192     case OP_BIT_AND:
4193     case OP_BIT_XOR:
4194     case OP_BIT_OR:
4195     case OP_I_MULTIPLY:
4196     case OP_I_DIVIDE:
4197     case OP_I_MODULO:
4198     case OP_I_ADD:
4199     case OP_I_SUBTRACT:
4200         if (!(o->op_flags & OPf_STACKED))
4201             goto nomod;
4202         PL_modcount++;
4203         break;
4204
4205     case OP_REPEAT:
4206         if (o->op_flags & OPf_STACKED) {
4207             PL_modcount++;
4208             break;
4209         }
4210         if (!(o->op_private & OPpREPEAT_DOLIST))
4211             goto nomod;
4212         else {
4213             const I32 mods = PL_modcount;
4214             modkids(cBINOPo->op_first, type);
4215             if (type != OP_AASSIGN)
4216                 goto nomod;
4217             kid = cBINOPo->op_last;
4218             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4219                 const IV iv = SvIV(kSVOP_sv);
4220                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4221                     PL_modcount =
4222                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4223             }
4224             else
4225                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4226         }
4227         break;
4228
4229     case OP_COND_EXPR:
4230         localize = 1;
4231         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4232             op_lvalue(kid, type);
4233         break;
4234
4235     case OP_RV2AV:
4236     case OP_RV2HV:
4237         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4238            PL_modcount = RETURN_UNLIMITED_NUMBER;
4239            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4240               fiable since some contexts need to know.  */
4241            o->op_flags |= OPf_MOD;
4242            return o;
4243         }
4244         /* FALLTHROUGH */
4245     case OP_RV2GV:
4246         if (scalar_mod_type(o, type))
4247             goto nomod;
4248         ref(cUNOPo->op_first, o->op_type);
4249         /* FALLTHROUGH */
4250     case OP_ASLICE:
4251     case OP_HSLICE:
4252         localize = 1;
4253         /* FALLTHROUGH */
4254     case OP_AASSIGN:
4255         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4256         if (type == OP_LEAVESUBLV && (
4257                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4258              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4259            ))
4260             o->op_private |= OPpMAYBE_LVSUB;
4261         /* FALLTHROUGH */
4262     case OP_NEXTSTATE:
4263     case OP_DBSTATE:
4264        PL_modcount = RETURN_UNLIMITED_NUMBER;
4265         break;
4266     case OP_KVHSLICE:
4267     case OP_KVASLICE:
4268     case OP_AKEYS:
4269         if (type == OP_LEAVESUBLV)
4270             o->op_private |= OPpMAYBE_LVSUB;
4271         goto nomod;
4272     case OP_AVHVSWITCH:
4273         if (type == OP_LEAVESUBLV
4274          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4275             o->op_private |= OPpMAYBE_LVSUB;
4276         goto nomod;
4277     case OP_AV2ARYLEN:
4278         PL_hints |= HINT_BLOCK_SCOPE;
4279         if (type == OP_LEAVESUBLV)
4280             o->op_private |= OPpMAYBE_LVSUB;
4281         PL_modcount++;
4282         break;
4283     case OP_RV2SV:
4284         ref(cUNOPo->op_first, o->op_type);
4285         localize = 1;
4286         /* FALLTHROUGH */
4287     case OP_GV:
4288         PL_hints |= HINT_BLOCK_SCOPE;
4289         /* FALLTHROUGH */
4290     case OP_SASSIGN:
4291     case OP_ANDASSIGN:
4292     case OP_ORASSIGN:
4293     case OP_DORASSIGN:
4294         PL_modcount++;
4295         break;
4296
4297     case OP_AELEMFAST:
4298     case OP_AELEMFAST_LEX:
4299         localize = -1;
4300         PL_modcount++;
4301         break;
4302
4303     case OP_PADAV:
4304     case OP_PADHV:
4305        PL_modcount = RETURN_UNLIMITED_NUMBER;
4306         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4307         {
4308            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4309               fiable since some contexts need to know.  */
4310             o->op_flags |= OPf_MOD;
4311             return o;
4312         }
4313         if (scalar_mod_type(o, type))
4314             goto nomod;
4315         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4316           && type == OP_LEAVESUBLV)
4317             o->op_private |= OPpMAYBE_LVSUB;
4318         /* FALLTHROUGH */
4319     case OP_PADSV:
4320         PL_modcount++;
4321         if (!type) /* local() */
4322             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4323                               PNfARG(PAD_COMPNAME(o->op_targ)));
4324         if (!(o->op_private & OPpLVAL_INTRO)
4325          || (  type != OP_SASSIGN && type != OP_AASSIGN
4326             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4327             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4328         break;
4329
4330     case OP_PUSHMARK:
4331         localize = 0;
4332         break;
4333
4334     case OP_KEYS:
4335         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4336             goto nomod;
4337         goto lvalue_func;
4338     case OP_SUBSTR:
4339         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4340             goto nomod;
4341         /* FALLTHROUGH */
4342     case OP_POS:
4343     case OP_VEC:
4344       lvalue_func:
4345         if (type == OP_LEAVESUBLV)
4346             o->op_private |= OPpMAYBE_LVSUB;
4347         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4348             /* substr and vec */
4349             /* If this op is in merely potential (non-fatal) modifiable
4350                context, then apply OP_ENTERSUB context to
4351                the kid op (to avoid croaking).  Other-
4352                wise pass this op’s own type so the correct op is mentioned
4353                in error messages.  */
4354             op_lvalue(OpSIBLING(cBINOPo->op_first),
4355                       S_potential_mod_type(type)
4356                         ? (I32)OP_ENTERSUB
4357                         : o->op_type);
4358         }
4359         break;
4360
4361     case OP_AELEM:
4362     case OP_HELEM:
4363         ref(cBINOPo->op_first, o->op_type);
4364         if (type == OP_ENTERSUB &&
4365              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4366             o->op_private |= OPpLVAL_DEFER;
4367         if (type == OP_LEAVESUBLV)
4368             o->op_private |= OPpMAYBE_LVSUB;
4369         localize = 1;
4370         PL_modcount++;
4371         break;
4372
4373     case OP_LEAVE:
4374     case OP_LEAVELOOP:
4375         o->op_private |= OPpLVALUE;
4376         /* FALLTHROUGH */
4377     case OP_SCOPE:
4378     case OP_ENTER:
4379     case OP_LINESEQ:
4380         localize = 0;
4381         if (o->op_flags & OPf_KIDS)
4382             op_lvalue(cLISTOPo->op_last, type);
4383         break;
4384
4385     case OP_NULL:
4386         localize = 0;
4387         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4388             goto nomod;
4389         else if (!(o->op_flags & OPf_KIDS))
4390             break;
4391
4392         if (o->op_targ != OP_LIST) {
4393             OP *sib = OpSIBLING(cLISTOPo->op_first);
4394             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4395              * that looks like
4396              *
4397              *   null
4398              *      arg
4399              *      trans
4400              *
4401              * compared with things like OP_MATCH which have the argument
4402              * as a child:
4403              *
4404              *   match
4405              *      arg
4406              *
4407              * so handle specially to correctly get "Can't modify" croaks etc
4408              */
4409
4410             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4411             {
4412                 /* this should trigger a "Can't modify transliteration" err */
4413                 op_lvalue(sib, type);
4414             }
4415             op_lvalue(cBINOPo->op_first, type);
4416             break;
4417         }
4418         /* FALLTHROUGH */
4419     case OP_LIST:
4420         localize = 0;
4421         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4422             /* elements might be in void context because the list is
4423                in scalar context or because they are attribute sub calls */
4424             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4425                 op_lvalue(kid, type);
4426         break;
4427
4428     case OP_COREARGS:
4429         return o;
4430
4431     case OP_AND:
4432     case OP_OR:
4433         if (type == OP_LEAVESUBLV
4434          || !S_vivifies(cLOGOPo->op_first->op_type))
4435             op_lvalue(cLOGOPo->op_first, type);
4436         if (type == OP_LEAVESUBLV
4437          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4438             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4439         goto nomod;
4440
4441     case OP_SREFGEN:
4442         if (type == OP_NULL) { /* local */
4443           local_refgen:
4444             if (!FEATURE_MYREF_IS_ENABLED)
4445                 Perl_croak(aTHX_ "The experimental declared_refs "
4446                                  "feature is not enabled");
4447             Perl_ck_warner_d(aTHX_
4448                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4449                     "Declaring references is experimental");
4450             op_lvalue(cUNOPo->op_first, OP_NULL);
4451             return o;
4452         }
4453         if (type != OP_AASSIGN && type != OP_SASSIGN
4454          && type != OP_ENTERLOOP)
4455             goto nomod;
4456         /* Don’t bother applying lvalue context to the ex-list.  */
4457         kid = cUNOPx(cUNOPo->op_first)->op_first;
4458         assert (!OpHAS_SIBLING(kid));
4459         goto kid_2lvref;
4460     case OP_REFGEN:
4461         if (type == OP_NULL) /* local */
4462             goto local_refgen;
4463         if (type != OP_AASSIGN) goto nomod;
4464         kid = cUNOPo->op_first;
4465       kid_2lvref:
4466         {
4467             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4468             S_lvref(aTHX_ kid, type);
4469             if (!PL_parser || PL_parser->error_count == ec) {
4470                 if (!FEATURE_REFALIASING_IS_ENABLED)
4471                     Perl_croak(aTHX_
4472                        "Experimental aliasing via reference not enabled");
4473                 Perl_ck_warner_d(aTHX_
4474                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4475                                 "Aliasing via reference is experimental");
4476             }
4477         }
4478         if (o->op_type == OP_REFGEN)
4479             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4480         op_null(o);
4481         return o;
4482
4483     case OP_SPLIT:
4484         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4485             /* This is actually @array = split.  */
4486             PL_modcount = RETURN_UNLIMITED_NUMBER;
4487             break;
4488         }
4489         goto nomod;
4490
4491     case OP_SCALAR:
4492         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4493         goto nomod;
4494     }
4495
4496     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4497        their argument is a filehandle; thus \stat(".") should not set
4498        it. AMS 20011102 */
4499     if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4500         return o;
4501
4502     if (type != OP_LEAVESUBLV)
4503         o->op_flags |= OPf_MOD;
4504
4505     if (type == OP_AASSIGN || type == OP_SASSIGN)
4506         o->op_flags |= OPf_SPECIAL
4507                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4508     else if (!type) { /* local() */
4509         switch (localize) {
4510         case 1:
4511             o->op_private |= OPpLVAL_INTRO;
4512             o->op_flags &= ~OPf_SPECIAL;
4513             PL_hints |= HINT_BLOCK_SCOPE;
4514             break;
4515         case 0:
4516             break;
4517         case -1:
4518             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4519                            "Useless localization of %s", OP_DESC(o));
4520         }
4521     }
4522     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4523              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4524         o->op_flags |= OPf_REF;
4525     return o;
4526 }
4527
4528 STATIC bool
4529 S_scalar_mod_type(const OP *o, I32 type)
4530 {
4531     switch (type) {
4532     case OP_POS:
4533     case OP_SASSIGN:
4534         if (o && o->op_type == OP_RV2GV)
4535             return FALSE;
4536         /* FALLTHROUGH */
4537     case OP_PREINC:
4538     case OP_PREDEC:
4539     case OP_POSTINC:
4540     case OP_POSTDEC:
4541     case OP_I_PREINC:
4542     case OP_I_PREDEC:
4543     case OP_I_POSTINC:
4544     case OP_I_POSTDEC:
4545     case OP_POW:
4546     case OP_MULTIPLY:
4547     case OP_DIVIDE:
4548     case OP_MODULO:
4549     case OP_REPEAT:
4550     case OP_ADD:
4551     case OP_SUBTRACT:
4552     case OP_I_MULTIPLY:
4553     case OP_I_DIVIDE:
4554     case OP_I_MODULO:
4555     case OP_I_ADD:
4556     case OP_I_SUBTRACT:
4557     case OP_LEFT_SHIFT:
4558     case OP_RIGHT_SHIFT:
4559     case OP_BIT_AND:
4560     case OP_BIT_XOR:
4561     case OP_BIT_OR:
4562     case OP_NBIT_AND:
4563     case OP_NBIT_XOR:
4564     case OP_NBIT_OR:
4565     case OP_SBIT_AND:
4566     case OP_SBIT_XOR:
4567     case OP_SBIT_OR:
4568     case OP_CONCAT:
4569     case OP_SUBST:
4570     case OP_TRANS:
4571     case OP_TRANSR:
4572     case OP_READ:
4573     case OP_SYSREAD:
4574     case OP_RECV:
4575     case OP_ANDASSIGN:
4576     case OP_ORASSIGN:
4577     case OP_DORASSIGN:
4578     case OP_VEC:
4579     case OP_SUBSTR:
4580         return TRUE;
4581     default:
4582         return FALSE;
4583     }
4584 }
4585
4586 STATIC bool
4587 S_is_handle_constructor(const OP *o, I32 numargs)
4588 {
4589     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4590
4591     switch (o->op_type) {
4592     case OP_PIPE_OP:
4593     case OP_SOCKPAIR:
4594         if (numargs == 2)
4595             return TRUE;
4596         /* FALLTHROUGH */
4597     case OP_SYSOPEN:
4598     case OP_OPEN:
4599     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4600     case OP_SOCKET:
4601     case OP_OPEN_DIR:
4602     case OP_ACCEPT:
4603         if (numargs == 1)
4604             return TRUE;
4605         /* FALLTHROUGH */
4606     default:
4607         return FALSE;
4608     }
4609 }
4610
4611 static OP *
4612 S_refkids(pTHX_ OP *o, I32 type)
4613 {
4614     if (o && o->op_flags & OPf_KIDS) {
4615         OP *kid;
4616         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4617             ref(kid, type);
4618     }
4619     return o;
4620 }
4621
4622 OP *
4623 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4624 {
4625     dVAR;
4626     OP *kid;
4627
4628     PERL_ARGS_ASSERT_DOREF;
4629
4630     if (PL_parser && PL_parser->error_count)
4631         return o;
4632
4633     switch (o->op_type) {
4634     case OP_ENTERSUB:
4635         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4636             !(o->op_flags & OPf_STACKED)) {
4637             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4638             assert(cUNOPo->op_first->op_type == OP_NULL);
4639             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4640             o->op_flags |= OPf_SPECIAL;
4641         }
4642         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4643             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4644                               : type == OP_RV2HV ? OPpDEREF_HV
4645                               : OPpDEREF_SV);
4646             o->op_flags |= OPf_MOD;
4647         }
4648
4649         break;
4650
4651     case OP_COND_EXPR:
4652         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4653             doref(kid, type, set_op_ref);
4654         break;
4655     case OP_RV2SV:
4656         if (type == OP_DEFINED)
4657             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4658         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4659         /* FALLTHROUGH */
4660     case OP_PADSV:
4661         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4662             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4663                               : type == OP_RV2HV ? OPpDEREF_HV
4664                               : OPpDEREF_SV);
4665             o->op_flags |= OPf_MOD;
4666         }
4667         break;
4668
4669     case OP_RV2AV:
4670     case OP_RV2HV:
4671         if (set_op_ref)
4672             o->op_flags |= OPf_REF;
4673         /* FALLTHROUGH */
4674     case OP_RV2GV:
4675         if (type == OP_DEFINED)
4676             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4677         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4678         break;
4679
4680     case OP_PADAV:
4681     case OP_PADHV:
4682         if (set_op_ref)
4683             o->op_flags |= OPf_REF;
4684         break;
4685
4686     case OP_SCALAR:
4687     case OP_NULL:
4688         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4689             break;
4690         doref(cBINOPo->op_first, type, set_op_ref);
4691         break;
4692     case OP_AELEM:
4693     case OP_HELEM:
4694         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4695         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4696             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4697                               : type == OP_RV2HV ? OPpDEREF_HV
4698                               : OPpDEREF_SV);
4699             o->op_flags |= OPf_MOD;
4700         }
4701         break;
4702
4703     case OP_SCOPE:
4704     case OP_LEAVE:
4705         set_op_ref = FALSE;
4706         /* FALLTHROUGH */
4707     case OP_ENTER:
4708     case OP_LIST:
4709         if (!(o->op_flags & OPf_KIDS))
4710             break;
4711         doref(cLISTOPo->op_last, type, set_op_ref);
4712         break;
4713     default:
4714         break;
4715