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