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