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