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