This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don't use PL_check[op_type] to check for filetets ops to stack
[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             assert(cUNOPo->op_first); /* OPf_KIDS implies op_first non-null */
888             for (kid = cUNOPo->op_first; kid; kid = nextkid) {
889                 nextkid = OpSIBLING(kid); /* Get before next freeing kid */
890                 if (kid->op_type == OP_FREED)
891                     /* During the forced freeing of ops after
892                        compilation failure, kidops may be freed before
893                        their parents. */
894                     continue;
895                 if (!(kid->op_flags & OPf_KIDS))
896                     /* If it has no kids, just free it now */
897                     op_free(kid);
898                 else
899                     DEFER_OP(kid);
900             }
901         }
902         if (type == OP_NULL)
903             type = (OPCODE)o->op_targ;
904
905         if (o->op_slabbed)
906             Slab_to_rw(OpSLAB(o));
907
908         /* COP* is not cleared by op_clear() so that we may track line
909          * numbers etc even after null() */
910         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
911             cop_free((COP*)o);
912         }
913
914         op_clear(o);
915         FreeOp(o);
916         if (PL_op == o)
917             PL_op = NULL;
918     } while ( (o = POP_DEFERRED_OP()) );
919
920     DEFER_OP_CLEANUP;
921 }
922
923 /* S_op_clear_gv(): free a GV attached to an OP */
924
925 STATIC
926 #ifdef USE_ITHREADS
927 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
928 #else
929 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
930 #endif
931 {
932
933     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
934             || o->op_type == OP_MULTIDEREF)
935 #ifdef USE_ITHREADS
936                 && PL_curpad
937                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
938 #else
939                 ? (GV*)(*svp) : NULL;
940 #endif
941     /* It's possible during global destruction that the GV is freed
942        before the optree. Whilst the SvREFCNT_inc is happy to bump from
943        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
944        will trigger an assertion failure, because the entry to sv_clear
945        checks that the scalar is not already freed.  A check of for
946        !SvIS_FREED(gv) turns out to be invalid, because during global
947        destruction the reference count can be forced down to zero
948        (with SVf_BREAK set).  In which case raising to 1 and then
949        dropping to 0 triggers cleanup before it should happen.  I
950        *think* that this might actually be a general, systematic,
951        weakness of the whole idea of SVf_BREAK, in that code *is*
952        allowed to raise and lower references during global destruction,
953        so any *valid* code that happens to do this during global
954        destruction might well trigger premature cleanup.  */
955     bool still_valid = gv && SvREFCNT(gv);
956
957     if (still_valid)
958         SvREFCNT_inc_simple_void(gv);
959 #ifdef USE_ITHREADS
960     if (*ixp > 0) {
961         pad_swipe(*ixp, TRUE);
962         *ixp = 0;
963     }
964 #else
965     SvREFCNT_dec(*svp);
966     *svp = NULL;
967 #endif
968     if (still_valid) {
969         int try_downgrade = SvREFCNT(gv) == 2;
970         SvREFCNT_dec_NN(gv);
971         if (try_downgrade)
972             gv_try_downgrade(gv);
973     }
974 }
975
976
977 void
978 Perl_op_clear(pTHX_ OP *o)
979 {
980
981     dVAR;
982
983     PERL_ARGS_ASSERT_OP_CLEAR;
984
985     switch (o->op_type) {
986     case OP_NULL:       /* Was holding old type, if any. */
987         /* FALLTHROUGH */
988     case OP_ENTERTRY:
989     case OP_ENTEREVAL:  /* Was holding hints. */
990     case OP_ARGDEFELEM: /* Was holding signature index. */
991         o->op_targ = 0;
992         break;
993     default:
994         if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
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             variant += variant_under_utf8_count((U8 *) argp->p,
3106                                                 (U8 *) argp->p + argp->len);
3107         }
3108     }
3109
3110     /* create and populate aux struct */
3111
3112   create_aux:
3113
3114     aux = (UNOP_AUX_item*)PerlMemShared_malloc(
3115                     sizeof(UNOP_AUX_item)
3116                     *  (
3117                            PERL_MULTICONCAT_HEADER_SIZE
3118                          + ((nargs + 1) * (variant ? 2 : 1))
3119                         )
3120                     );
3121     const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
3122
3123     /* Extract all the non-const expressions from the concat tree then
3124      * dispose of the old tree, e.g. convert the tree from this:
3125      *
3126      *  o => SASSIGN
3127      *         |
3128      *       STRINGIFY   -- TARGET
3129      *         |
3130      *       ex-PUSHMARK -- CONCAT
3131      *                        |
3132      *                      CONCAT -- EXPR5
3133      *                        |
3134      *                      CONCAT -- EXPR4
3135      *                        |
3136      *                      CONCAT -- EXPR3
3137      *                        |
3138      *                      EXPR1  -- EXPR2
3139      *
3140      *
3141      * to:
3142      *
3143      *  o => MULTICONCAT
3144      *         |
3145      *       ex-PUSHMARK -- EXPR1 -- EXPR2 -- EXPR3 -- EXPR4 -- EXPR5 -- TARGET
3146      *
3147      * except that if EXPRi is an OP_CONST, it's discarded.
3148      *
3149      * During the conversion process, EXPR ops are stripped from the tree
3150      * and unshifted onto o. Finally, any of o's remaining original
3151      * childen are discarded and o is converted into an OP_MULTICONCAT.
3152      *
3153      * In this middle of this, o may contain both: unshifted args on the
3154      * left, and some remaining original args on the right. lastkidop
3155      * is set to point to the right-most unshifted arg to delineate
3156      * between the two sets.
3157      */
3158
3159
3160     if (is_sprintf) {
3161         /* create a copy of the format with the %'s removed, and record
3162          * the sizes of the const string segments in the aux struct */
3163         char *q, *oldq;
3164         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3165
3166         p    = sprintf_info.start;
3167         q    = const_str;
3168         oldq = q;
3169         for (; p < sprintf_info.end; p++) {
3170             if (*p == '%') {
3171                 p++;
3172                 if (*p != '%') {
3173                     (lenp++)->ssize = q - oldq;
3174                     oldq = q;
3175                     continue;
3176                 }
3177             }
3178             *q++ = *p;
3179         }
3180         lenp->ssize = q - oldq;
3181         assert((STRLEN)(q - const_str) == total_len);
3182
3183         /* Attach all the args (i.e. the kids of the sprintf) to o (which
3184          * may or may not be topop) The pushmark and const ops need to be
3185          * kept in case they're an op_next entry point.
3186          */
3187         lastkidop = cLISTOPx(topop)->op_last;
3188         kid = cUNOPx(topop)->op_first; /* pushmark */
3189         op_null(kid);
3190         op_null(OpSIBLING(kid));       /* const */
3191         if (o != topop) {
3192             kid = op_sibling_splice(topop, NULL, -1, NULL); /* cut all args */
3193             op_sibling_splice(o, NULL, 0, kid); /* and attach to o */
3194             lastkidop->op_next = o;
3195         }
3196     }
3197     else {
3198         p = const_str;
3199         lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
3200
3201         lenp->ssize = -1;
3202
3203         /* Concatenate all const strings into const_str.
3204          * Note that args[] contains the RHS args in reverse order, so
3205          * we scan args[] from top to bottom to get constant strings
3206          * in L-R order
3207          */
3208         for (argp = toparg; argp >= args; argp--) {
3209             if (!argp->p)
3210                 /* not a const op */
3211                 (++lenp)->ssize = -1;
3212             else {
3213                 STRLEN l = argp->len;
3214                 Copy(argp->p, p, l, char);
3215                 p += l;
3216                 if (lenp->ssize == -1)
3217                     lenp->ssize = l;
3218                 else
3219                     lenp->ssize += l;
3220             }
3221         }
3222
3223         kid = topop;
3224         nextop = o;
3225         lastkidop = NULL;
3226
3227         for (argp = args; argp <= toparg; argp++) {
3228             /* only keep non-const args, except keep the first-in-next-chain
3229              * arg no matter what it is (but nulled if OP_CONST), because it
3230              * may be the entry point to this subtree from the previous
3231              * op_next.
3232              */
3233             bool last = (argp == toparg);
3234             OP *prev;
3235
3236             /* set prev to the sibling *before* the arg to be cut out,
3237              * e.g. when cutting EXPR:
3238              *
3239              *         |
3240              * kid=  CONCAT
3241              *         |
3242              * prev= CONCAT -- EXPR
3243              *         |
3244              */
3245             if (argp == args && kid->op_type != OP_CONCAT) {
3246                 /* in e.g. '$x .= f(1)' there's no RHS concat tree
3247                  * so the expression to be cut isn't kid->op_last but
3248                  * kid itself */
3249                 OP *o1, *o2;
3250                 /* find the op before kid */
3251                 o1 = NULL;
3252                 o2 = cUNOPx(parentop)->op_first;
3253                 while (o2 && o2 != kid) {
3254                     o1 = o2;
3255                     o2 = OpSIBLING(o2);
3256                 }
3257                 assert(o2 == kid);
3258                 prev = o1;
3259                 kid  = parentop;
3260             }
3261             else if (kid == o && lastkidop)
3262                 prev = last ? lastkidop : OpSIBLING(lastkidop);
3263             else
3264                 prev = last ? NULL : cUNOPx(kid)->op_first;
3265
3266             if (!argp->p || last) {
3267                 /* cut RH op */
3268                 OP *aop = op_sibling_splice(kid, prev, 1, NULL);
3269                 /* and unshift to front of o */
3270                 op_sibling_splice(o, NULL, 0, aop);
3271                 /* record the right-most op added to o: later we will
3272                  * free anything to the right of it */
3273                 if (!lastkidop)
3274                     lastkidop = aop;
3275                 aop->op_next = nextop;
3276                 if (last) {
3277                     if (argp->p)
3278                         /* null the const at start of op_next chain */
3279                         op_null(aop);
3280                 }
3281                 else if (prev)
3282                     nextop = prev->op_next;
3283             }
3284
3285             /* the last two arguments are both attached to the same concat op */
3286             if (argp < toparg - 1)
3287                 kid = prev;
3288         }
3289     }
3290
3291     /* Populate the aux struct */
3292
3293     aux[PERL_MULTICONCAT_IX_NARGS].ssize     = nargs;
3294     aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv    = utf8 ? NULL : const_str;
3295     aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ?    0 : total_len;
3296     aux[PERL_MULTICONCAT_IX_UTF8_PV].pv     = const_str;
3297     aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize  = total_len;
3298
3299     /* if variant > 0, calculate a variant const string and lengths where
3300      * the utf8 version of the string will take 'variant' more bytes than
3301      * the plain one. */
3302
3303     if (variant) {
3304         char              *p = const_str;
3305         STRLEN          ulen = total_len + variant;
3306         UNOP_AUX_item  *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3307         UNOP_AUX_item *ulens = lens + (nargs + 1);
3308         char             *up = (char*)PerlMemShared_malloc(ulen);
3309         SSize_t            n;
3310
3311         aux[PERL_MULTICONCAT_IX_UTF8_PV].pv    = up;
3312         aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
3313
3314         for (n = 0; n < (nargs + 1); n++) {
3315             SSize_t i;
3316             char * orig_up = up;
3317             for (i = (lens++)->ssize; i > 0; i--) {
3318                 U8 c = *p++;
3319                 append_utf8_from_native_byte(c, (U8**)&up);
3320             }
3321             (ulens++)->ssize = (i < 0) ? i : up - orig_up;
3322         }
3323     }
3324
3325     if (stringop) {
3326         /* if there was a top(ish)-level OP_STRINGIFY, we need to keep
3327          * that op's first child - an ex-PUSHMARK - because the op_next of
3328          * the previous op may point to it (i.e. it's the entry point for
3329          * the o optree)
3330          */
3331         OP *pmop =
3332             (stringop == o)
3333                 ? op_sibling_splice(o, lastkidop, 1, NULL)
3334                 : op_sibling_splice(stringop, NULL, 1, NULL);
3335         assert(OP_TYPE_IS_OR_WAS_NN(pmop, OP_PUSHMARK));
3336         op_sibling_splice(o, NULL, 0, pmop);
3337         if (!lastkidop)
3338             lastkidop = pmop;
3339     }
3340
3341     /* Optimise 
3342      *    target  = A.B.C...
3343      *    target .= A.B.C...
3344      */
3345
3346     if (targetop) {
3347         assert(!targmyop);
3348
3349         if (o->op_type == OP_SASSIGN) {
3350             /* Move the target subtree from being the last of o's children
3351              * to being the last of o's preserved children.
3352              * Note the difference between 'target = ...' and 'target .= ...':
3353              * for the former, target is executed last; for the latter,
3354              * first.
3355              */
3356             kid = OpSIBLING(lastkidop);
3357             op_sibling_splice(o, kid, 1, NULL); /* cut target op */
3358             op_sibling_splice(o, lastkidop, 0, targetop); /* and paste */
3359             lastkidop->op_next = kid->op_next;
3360             lastkidop = targetop;
3361         }
3362         else {
3363             /* Move the target subtree from being the first of o's
3364              * original children to being the first of *all* o's children.
3365              */
3366             if (lastkidop) {
3367                 op_sibling_splice(o, lastkidop, 1, NULL); /* cut target op */
3368                 op_sibling_splice(o, NULL, 0, targetop);  /* and paste*/
3369             }
3370             else {
3371                 /* if the RHS of .= doesn't contain a concat (e.g.
3372                  * $x .= "foo"), it gets missed by the "strip ops from the
3373                  * tree and add to o" loop earlier */
3374                 assert(topop->op_type != OP_CONCAT);
3375                 if (stringop) {
3376                     /* in e.g. $x .= "$y", move the $y expression
3377                      * from being a child of OP_STRINGIFY to being the
3378                      * second child of the OP_CONCAT
3379                      */
3380                     assert(cUNOPx(stringop)->op_first == topop);
3381                     op_sibling_splice(stringop, NULL, 1, NULL);
3382                     op_sibling_splice(o, cUNOPo->op_first, 0, topop);
3383                 }
3384                 assert(topop == OpSIBLING(cBINOPo->op_first));
3385                 if (toparg->p)
3386                     op_null(topop);
3387                 lastkidop = topop;
3388             }
3389         }
3390
3391         if (is_targable) {
3392             /* optimise
3393              *  my $lex  = A.B.C...
3394              *     $lex  = A.B.C...
3395              *     $lex .= A.B.C...
3396              * The original padsv op is kept but nulled in case it's the
3397              * entry point for the optree (which it will be for
3398              * '$lex .=  ... '
3399              */
3400             private_flags |= OPpTARGET_MY;
3401             private_flags |= (targetop->op_private & OPpLVAL_INTRO);
3402             o->op_targ = targetop->op_targ;
3403             targetop->op_targ = 0;
3404             op_null(targetop);
3405         }
3406         else
3407             flags |= OPf_STACKED;
3408     }
3409     else if (targmyop) {
3410         private_flags |= OPpTARGET_MY;
3411         if (o != targmyop) {
3412             o->op_targ = targmyop->op_targ;
3413             targmyop->op_targ = 0;
3414         }
3415     }
3416
3417     /* detach the emaciated husk of the sprintf/concat optree and free it */
3418     for (;;) {
3419         kid = op_sibling_splice(o, lastkidop, 1, NULL);
3420         if (!kid)
3421             break;
3422         op_free(kid);
3423     }
3424
3425     /* and convert o into a multiconcat */
3426
3427     o->op_flags        = (flags|OPf_KIDS|stacked_last
3428                          |(o->op_flags & (OPf_WANT|OPf_PARENS)));
3429     o->op_private      = private_flags;
3430     o->op_type         = OP_MULTICONCAT;
3431     o->op_ppaddr       = PL_ppaddr[OP_MULTICONCAT];
3432     cUNOP_AUXo->op_aux = aux;
3433 }
3434
3435
3436 /* do all the final processing on an optree (e.g. running the peephole
3437  * optimiser on it), then attach it to cv (if cv is non-null)
3438  */
3439
3440 static void
3441 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
3442 {
3443     OP **startp;
3444
3445     /* XXX for some reason, evals, require and main optrees are
3446      * never attached to their CV; instead they just hang off
3447      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
3448      * and get manually freed when appropriate */
3449     if (cv)
3450         startp = &CvSTART(cv);
3451     else
3452         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
3453
3454     *startp = start;
3455     optree->op_private |= OPpREFCOUNTED;
3456     OpREFCNT_set(optree, 1);
3457     optimize_optree(optree);
3458     CALL_PEEP(*startp);
3459     finalize_optree(optree);
3460     S_prune_chain_head(startp);
3461
3462     if (cv) {
3463         /* now that optimizer has done its work, adjust pad values */
3464         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
3465                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
3466     }
3467 }
3468
3469
3470 /*
3471 =for apidoc optimize_optree
3472
3473 This function applies some optimisations to the optree in top-down order.
3474 It is called before the peephole optimizer, which processes ops in
3475 execution order. Note that finalize_optree() also does a top-down scan,
3476 but is called *after* the peephole optimizer.
3477
3478 =cut
3479 */
3480
3481 void
3482 Perl_optimize_optree(pTHX_ OP* o)
3483 {
3484     PERL_ARGS_ASSERT_OPTIMIZE_OPTREE;
3485
3486     ENTER;
3487     SAVEVPTR(PL_curcop);
3488
3489     optimize_op(o);
3490
3491     LEAVE;
3492 }
3493
3494
3495 /* helper for optimize_optree() which optimises on op then recurses
3496  * to optimise any children.
3497  */
3498
3499 STATIC void
3500 S_optimize_op(pTHX_ OP* o)
3501 {
3502     dDEFER_OP;
3503
3504     PERL_ARGS_ASSERT_OPTIMIZE_OP;
3505     do {
3506         assert(o->op_type != OP_FREED);
3507
3508         switch (o->op_type) {
3509         case OP_NEXTSTATE:
3510         case OP_DBSTATE:
3511             PL_curcop = ((COP*)o);              /* for warnings */
3512             break;
3513
3514
3515         case OP_CONCAT:
3516         case OP_SASSIGN:
3517         case OP_STRINGIFY:
3518         case OP_SPRINTF:
3519             S_maybe_multiconcat(aTHX_ o);
3520             break;
3521
3522         case OP_SUBST:
3523             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3524                 DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
3525             break;
3526
3527         default:
3528             break;
3529         }
3530
3531         if (o->op_flags & OPf_KIDS) {
3532             OP *kid;
3533             IV child_count = 0;
3534             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3535                 DEFER_OP(kid);
3536                 ++child_count;
3537             }
3538             DEFER_REVERSE(child_count);
3539         }
3540     } while ( ( o = POP_DEFERRED_OP() ) );
3541
3542     DEFER_OP_CLEANUP;
3543 }
3544
3545
3546 /*
3547 =for apidoc finalize_optree
3548
3549 This function finalizes the optree.  Should be called directly after
3550 the complete optree is built.  It does some additional
3551 checking which can't be done in the normal C<ck_>xxx functions and makes
3552 the tree thread-safe.
3553
3554 =cut
3555 */
3556 void
3557 Perl_finalize_optree(pTHX_ OP* o)
3558 {
3559     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
3560
3561     ENTER;
3562     SAVEVPTR(PL_curcop);
3563
3564     finalize_op(o);
3565
3566     LEAVE;
3567 }
3568
3569 #ifdef USE_ITHREADS
3570 /* Relocate sv to the pad for thread safety.
3571  * Despite being a "constant", the SV is written to,
3572  * for reference counts, sv_upgrade() etc. */
3573 PERL_STATIC_INLINE void
3574 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
3575 {
3576     PADOFFSET ix;
3577     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
3578     if (!*svp) return;
3579     ix = pad_alloc(OP_CONST, SVf_READONLY);
3580     SvREFCNT_dec(PAD_SVl(ix));
3581     PAD_SETSV(ix, *svp);
3582     /* XXX I don't know how this isn't readonly already. */
3583     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
3584     *svp = NULL;
3585     *targp = ix;
3586 }
3587 #endif
3588
3589 /*
3590 =for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
3591
3592 Return the next op in a depth-first traversal of the op tree,
3593 returning NULL when the traversal is complete.
3594
3595 The initial call must supply the root of the tree as both top and o.
3596
3597 For now it's static, but it may be exposed to the API in the future.
3598
3599 =cut
3600 */
3601
3602 STATIC OP*
3603 S_traverse_op_tree(pTHX_ OP *top, OP *o) {
3604     OP *sib;
3605
3606     PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
3607
3608     if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
3609         return cUNOPo->op_first;
3610     }
3611     else if ((sib = OpSIBLING(o))) {
3612         return sib;
3613     }
3614     else {
3615         OP *parent = o->op_sibparent;
3616         assert(!(o->op_moresib));
3617         while (parent && parent != top) {
3618             OP *sib = OpSIBLING(parent);
3619             if (sib)
3620                 return sib;
3621             parent = parent->op_sibparent;
3622         }
3623
3624         return NULL;
3625     }
3626 }
3627
3628 STATIC void
3629 S_finalize_op(pTHX_ OP* o)
3630 {
3631     OP * const top = o;
3632     PERL_ARGS_ASSERT_FINALIZE_OP;
3633
3634     do {
3635         assert(o->op_type != OP_FREED);
3636
3637         switch (o->op_type) {
3638         case OP_NEXTSTATE:
3639         case OP_DBSTATE:
3640             PL_curcop = ((COP*)o);              /* for warnings */
3641             break;
3642         case OP_EXEC:
3643             if (OpHAS_SIBLING(o)) {
3644                 OP *sib = OpSIBLING(o);
3645                 if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
3646                     && ckWARN(WARN_EXEC)
3647                     && OpHAS_SIBLING(sib))
3648                 {
3649                     const OPCODE type = OpSIBLING(sib)->op_type;
3650                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
3651                         const line_t oldline = CopLINE(PL_curcop);
3652                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
3653                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3654                             "Statement unlikely to be reached");
3655                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
3656                             "\t(Maybe you meant system() when you said exec()?)\n");
3657                         CopLINE_set(PL_curcop, oldline);
3658                     }
3659                 }
3660             }
3661             break;
3662
3663         case OP_GV:
3664             if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
3665                 GV * const gv = cGVOPo_gv;
3666                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
3667                     /* XXX could check prototype here instead of just carping */
3668                     SV * const sv = sv_newmortal();
3669                     gv_efullname3(sv, gv, NULL);
3670                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3671                                 "%" SVf "() called too early to check prototype",
3672                                 SVfARG(sv));
3673                 }
3674             }
3675             break;
3676
3677         case OP_CONST:
3678             if (cSVOPo->op_private & OPpCONST_STRICT)
3679                 no_bareword_allowed(o);
3680 #ifdef USE_ITHREADS
3681             /* FALLTHROUGH */
3682         case OP_HINTSEVAL:
3683             op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
3684 #endif
3685             break;
3686
3687 #ifdef USE_ITHREADS
3688             /* Relocate all the METHOP's SVs to the pad for thread safety. */
3689         case OP_METHOD_NAMED:
3690         case OP_METHOD_SUPER:
3691         case OP_METHOD_REDIR:
3692         case OP_METHOD_REDIR_SUPER:
3693             op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
3694             break;
3695 #endif
3696
3697         case OP_HELEM: {
3698             UNOP *rop;
3699             SVOP *key_op;
3700             OP *kid;
3701
3702             if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
3703                 break;
3704
3705             rop = (UNOP*)((BINOP*)o)->op_first;
3706
3707             goto check_keys;
3708
3709             case OP_HSLICE:
3710                 S_scalar_slice_warning(aTHX_ o);
3711                 /* FALLTHROUGH */
3712
3713             case OP_KVHSLICE:
3714                 kid = OpSIBLING(cLISTOPo->op_first);
3715             if (/* I bet there's always a pushmark... */
3716                 OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
3717                 && OP_TYPE_ISNT_NN(kid, OP_CONST))
3718             {
3719                 break;
3720             }
3721
3722             key_op = (SVOP*)(kid->op_type == OP_CONST
3723                              ? kid
3724                              : OpSIBLING(kLISTOP->op_first));
3725
3726             rop = (UNOP*)((LISTOP*)o)->op_last;
3727
3728         check_keys:
3729             if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
3730                 rop = NULL;
3731             S_check_hash_fields_and_hekify(aTHX_ rop, key_op, 1);
3732             break;
3733         }
3734         case OP_NULL:
3735             if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
3736                 break;
3737             /* FALLTHROUGH */
3738         case OP_ASLICE:
3739             S_scalar_slice_warning(aTHX_ o);
3740             break;
3741
3742         case OP_SUBST: {
3743             if (cPMOPo->op_pmreplrootu.op_pmreplroot)
3744                 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
3745             break;
3746         }
3747         default:
3748             break;
3749         }
3750
3751 #ifdef DEBUGGING
3752         if (o->op_flags & OPf_KIDS) {
3753             OP *kid;
3754
3755             /* check that op_last points to the last sibling, and that
3756              * the last op_sibling/op_sibparent field points back to the
3757              * parent, and that the only ops with KIDS are those which are
3758              * entitled to them */
3759             U32 type = o->op_type;
3760             U32 family;
3761             bool has_last;
3762
3763             if (type == OP_NULL) {
3764                 type = o->op_targ;
3765                 /* ck_glob creates a null UNOP with ex-type GLOB
3766                  * (which is a list op. So pretend it wasn't a listop */
3767                 if (type == OP_GLOB)
3768                     type = OP_NULL;
3769             }
3770             family = PL_opargs[type] & OA_CLASS_MASK;
3771
3772             has_last = (   family == OA_BINOP
3773                         || family == OA_LISTOP
3774                         || family == OA_PMOP
3775                         || family == OA_LOOP
3776                        );
3777             assert(  has_last /* has op_first and op_last, or ...
3778                   ... has (or may have) op_first: */
3779                   || family == OA_UNOP
3780                   || family == OA_UNOP_AUX
3781                   || family == OA_LOGOP
3782                   || family == OA_BASEOP_OR_UNOP
3783                   || family == OA_FILESTATOP
3784                   || family == OA_LOOPEXOP
3785                   || family == OA_METHOP
3786                   || type == OP_CUSTOM
3787                   || type == OP_NULL /* new_logop does this */
3788                   );
3789
3790             for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3791                 if (!OpHAS_SIBLING(kid)) {
3792                     if (has_last)
3793                         assert(kid == cLISTOPo->op_last);
3794                     assert(kid->op_sibparent == o);
3795                 }
3796             }
3797         }
3798 #endif
3799     } while (( o = traverse_op_tree(top, o)) != NULL);
3800 }
3801
3802 /*
3803 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
3804
3805 Propagate lvalue ("modifiable") context to an op and its children.
3806 C<type> represents the context type, roughly based on the type of op that
3807 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3808 because it has no op type of its own (it is signalled by a flag on
3809 the lvalue op).
3810
3811 This function detects things that can't be modified, such as C<$x+1>, and
3812 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3813 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3814
3815 It also flags things that need to behave specially in an lvalue context,
3816 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3817
3818 =cut
3819 */
3820
3821 static void
3822 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
3823 {
3824     CV *cv = PL_compcv;
3825     PadnameLVALUE_on(pn);
3826     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
3827         cv = CvOUTSIDE(cv);
3828         /* RT #127786: cv can be NULL due to an eval within the DB package
3829          * called from an anon sub - anon subs don't have CvOUTSIDE() set
3830          * unless they contain an eval, but calling eval within DB
3831          * pretends the eval was done in the caller's scope.
3832          */
3833         if (!cv)
3834             break;
3835         assert(CvPADLIST(cv));
3836         pn =
3837            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
3838         assert(PadnameLEN(pn));
3839         PadnameLVALUE_on(pn);
3840     }
3841 }
3842
3843 static bool
3844 S_vivifies(const OPCODE type)
3845 {
3846     switch(type) {
3847     case OP_RV2AV:     case   OP_ASLICE:
3848     case OP_RV2HV:     case OP_KVASLICE:
3849     case OP_RV2SV:     case   OP_HSLICE:
3850     case OP_AELEMFAST: case OP_KVHSLICE:
3851     case OP_HELEM:
3852     case OP_AELEM:
3853         return 1;
3854     }
3855     return 0;
3856 }
3857
3858 static void
3859 S_lvref(pTHX_ OP *o, I32 type)
3860 {
3861     dVAR;
3862     OP *kid;
3863     switch (o->op_type) {
3864     case OP_COND_EXPR:
3865         for (kid = OpSIBLING(cUNOPo->op_first); kid;
3866              kid = OpSIBLING(kid))
3867             S_lvref(aTHX_ kid, type);
3868         /* FALLTHROUGH */
3869     case OP_PUSHMARK:
3870         return;
3871     case OP_RV2AV:
3872         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3873         o->op_flags |= OPf_STACKED;
3874         if (o->op_flags & OPf_PARENS) {
3875             if (o->op_private & OPpLVAL_INTRO) {
3876                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
3877                       "localized parenthesized array in list assignment"));
3878                 return;
3879             }
3880           slurpy:
3881             OpTYPE_set(o, OP_LVAVREF);
3882             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
3883             o->op_flags |= OPf_MOD|OPf_REF;
3884             return;
3885         }
3886         o->op_private |= OPpLVREF_AV;
3887         goto checkgv;
3888     case OP_RV2CV:
3889         kid = cUNOPo->op_first;
3890         if (kid->op_type == OP_NULL)
3891             kid = cUNOPx(OpSIBLING(kUNOP->op_first))
3892                 ->op_first;
3893         o->op_private = OPpLVREF_CV;
3894         if (kid->op_type == OP_GV)
3895             o->op_flags |= OPf_STACKED;
3896         else if (kid->op_type == OP_PADCV) {
3897             o->op_targ = kid->op_targ;
3898             kid->op_targ = 0;
3899             op_free(cUNOPo->op_first);
3900             cUNOPo->op_first = NULL;
3901             o->op_flags &=~ OPf_KIDS;
3902         }
3903         else goto badref;
3904         break;
3905     case OP_RV2HV:
3906         if (o->op_flags & OPf_PARENS) {
3907           parenhash:
3908             yyerror(Perl_form(aTHX_ "Can't modify reference to "
3909                                  "parenthesized hash in list assignment"));
3910                 return;
3911         }
3912         o->op_private |= OPpLVREF_HV;
3913         /* FALLTHROUGH */
3914     case OP_RV2SV:
3915       checkgv:
3916         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
3917         o->op_flags |= OPf_STACKED;
3918         break;
3919     case OP_PADHV:
3920         if (o->op_flags & OPf_PARENS) goto parenhash;
3921         o->op_private |= OPpLVREF_HV;
3922         /* FALLTHROUGH */
3923     case OP_PADSV:
3924         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3925         break;
3926     case OP_PADAV:
3927         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
3928         if (o->op_flags & OPf_PARENS) goto slurpy;
3929         o->op_private |= OPpLVREF_AV;
3930         break;
3931     case OP_AELEM:
3932     case OP_HELEM:
3933         o->op_private |= OPpLVREF_ELEM;
3934         o->op_flags   |= OPf_STACKED;
3935         break;
3936     case OP_ASLICE:
3937     case OP_HSLICE:
3938         OpTYPE_set(o, OP_LVREFSLICE);
3939         o->op_private &= OPpLVAL_INTRO;
3940         return;
3941     case OP_NULL:
3942         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
3943             goto badref;
3944         else if (!(o->op_flags & OPf_KIDS))
3945             return;
3946         if (o->op_targ != OP_LIST) {
3947             S_lvref(aTHX_ cBINOPo->op_first, type);
3948             return;
3949         }
3950         /* FALLTHROUGH */
3951     case OP_LIST:
3952         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid)) {
3953             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
3954             S_lvref(aTHX_ kid, type);
3955         }
3956         return;
3957     case OP_STUB:
3958         if (o->op_flags & OPf_PARENS)
3959             return;
3960         /* FALLTHROUGH */
3961     default:
3962       badref:
3963         /* diag_listed_as: Can't modify reference to %s in %s assignment */
3964         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
3965                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
3966                       ? "do block"
3967                       : OP_DESC(o),
3968                      PL_op_desc[type]));
3969         return;
3970     }
3971     OpTYPE_set(o, OP_LVREF);
3972     o->op_private &=
3973         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
3974     if (type == OP_ENTERLOOP)
3975         o->op_private |= OPpLVREF_ITER;
3976 }
3977
3978 PERL_STATIC_INLINE bool
3979 S_potential_mod_type(I32 type)
3980 {
3981     /* Types that only potentially result in modification.  */
3982     return type == OP_GREPSTART || type == OP_ENTERSUB
3983         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3984 }
3985
3986 OP *
3987 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3988 {
3989     dVAR;
3990     OP *kid;
3991     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3992     int localize = -1;
3993
3994     if (!o || (PL_parser && PL_parser->error_count))
3995         return o;
3996
3997     if ((o->op_private & OPpTARGET_MY)
3998         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3999     {
4000         return o;
4001     }
4002
4003     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
4004
4005     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
4006
4007     switch (o->op_type) {
4008     case OP_UNDEF:
4009         PL_modcount++;
4010         return o;
4011     case OP_STUB:
4012         if ((o->op_flags & OPf_PARENS))
4013             break;
4014         goto nomod;
4015     case OP_ENTERSUB:
4016         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
4017             !(o->op_flags & OPf_STACKED)) {
4018             OpTYPE_set(o, OP_RV2CV);            /* entersub => rv2cv */
4019             assert(cUNOPo->op_first->op_type == OP_NULL);
4020             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
4021             break;
4022         }
4023         else {                          /* lvalue subroutine call */
4024             o->op_private |= OPpLVAL_INTRO;
4025             PL_modcount = RETURN_UNLIMITED_NUMBER;
4026             if (S_potential_mod_type(type)) {
4027                 o->op_private |= OPpENTERSUB_INARGS;
4028                 break;
4029             }
4030             else {                      /* Compile-time error message: */
4031                 OP *kid = cUNOPo->op_first;
4032                 CV *cv;
4033                 GV *gv;
4034                 SV *namesv;
4035
4036                 if (kid->op_type != OP_PUSHMARK) {
4037                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
4038                         Perl_croak(aTHX_
4039                                 "panic: unexpected lvalue entersub "
4040                                 "args: type/targ %ld:%" UVuf,
4041                                 (long)kid->op_type, (UV)kid->op_targ);
4042                     kid = kLISTOP->op_first;
4043                 }
4044                 while (OpHAS_SIBLING(kid))
4045                     kid = OpSIBLING(kid);
4046                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
4047                     break;      /* Postpone until runtime */
4048                 }
4049
4050                 kid = kUNOP->op_first;
4051                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
4052                     kid = kUNOP->op_first;
4053                 if (kid->op_type == OP_NULL)
4054                     Perl_croak(aTHX_
4055                                "Unexpected constant lvalue entersub "
4056                                "entry via type/targ %ld:%" UVuf,
4057                                (long)kid->op_type, (UV)kid->op_targ);
4058                 if (kid->op_type != OP_GV) {
4059                     break;
4060                 }
4061
4062                 gv = kGVOP_gv;
4063                 cv = isGV(gv)
4064                     ? GvCV(gv)
4065                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
4066                         ? MUTABLE_CV(SvRV(gv))
4067                         : NULL;
4068                 if (!cv)
4069                     break;
4070                 if (CvLVALUE(cv))
4071                     break;
4072                 if (flags & OP_LVALUE_NO_CROAK)
4073                     return NULL;
4074
4075                 namesv = cv_name(cv, NULL, 0);
4076                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
4077                                      "subroutine call of &%" SVf " in %s",
4078                                      SVfARG(namesv), PL_op_desc[type]),
4079                            SvUTF8(namesv));
4080                 return o;
4081             }
4082         }
4083         /* FALLTHROUGH */
4084     default:
4085       nomod:
4086         if (flags & OP_LVALUE_NO_CROAK) return NULL;
4087         /* grep, foreach, subcalls, refgen */
4088         if (S_potential_mod_type(type))
4089             break;
4090         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
4091                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
4092                       ? "do block"
4093                       : OP_DESC(o)),
4094                      type ? PL_op_desc[type] : "local"));
4095         return o;
4096
4097     case OP_PREINC:
4098     case OP_PREDEC:
4099     case OP_POW:
4100     case OP_MULTIPLY:
4101     case OP_DIVIDE:
4102     case OP_MODULO:
4103     case OP_ADD:
4104     case OP_SUBTRACT:
4105     case OP_CONCAT:
4106     case OP_LEFT_SHIFT:
4107     case OP_RIGHT_SHIFT:
4108     case OP_BIT_AND:
4109     case OP_BIT_XOR:
4110     case OP_BIT_OR:
4111     case OP_I_MULTIPLY:
4112     case OP_I_DIVIDE:
4113     case OP_I_MODULO:
4114     case OP_I_ADD:
4115     case OP_I_SUBTRACT:
4116         if (!(o->op_flags & OPf_STACKED))
4117             goto nomod;
4118         PL_modcount++;
4119         break;
4120
4121     case OP_REPEAT:
4122         if (o->op_flags & OPf_STACKED) {
4123             PL_modcount++;
4124             break;
4125         }
4126         if (!(o->op_private & OPpREPEAT_DOLIST))
4127             goto nomod;
4128         else {
4129             const I32 mods = PL_modcount;
4130             modkids(cBINOPo->op_first, type);
4131             if (type != OP_AASSIGN)
4132                 goto nomod;
4133             kid = cBINOPo->op_last;
4134             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
4135                 const IV iv = SvIV(kSVOP_sv);
4136                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
4137                     PL_modcount =
4138                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
4139             }
4140             else
4141                 PL_modcount = RETURN_UNLIMITED_NUMBER;
4142         }
4143         break;
4144
4145     case OP_COND_EXPR:
4146         localize = 1;
4147         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4148             op_lvalue(kid, type);
4149         break;
4150
4151     case OP_RV2AV:
4152     case OP_RV2HV:
4153         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
4154            PL_modcount = RETURN_UNLIMITED_NUMBER;
4155            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4156               fiable since some contexts need to know.  */
4157            o->op_flags |= OPf_MOD;
4158            return o;
4159         }
4160         /* FALLTHROUGH */
4161     case OP_RV2GV:
4162         if (scalar_mod_type(o, type))
4163             goto nomod;
4164         ref(cUNOPo->op_first, o->op_type);
4165         /* FALLTHROUGH */
4166     case OP_ASLICE:
4167     case OP_HSLICE:
4168         localize = 1;
4169         /* FALLTHROUGH */
4170     case OP_AASSIGN:
4171         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
4172         if (type == OP_LEAVESUBLV && (
4173                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
4174              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4175            ))
4176             o->op_private |= OPpMAYBE_LVSUB;
4177         /* FALLTHROUGH */
4178     case OP_NEXTSTATE:
4179     case OP_DBSTATE:
4180        PL_modcount = RETURN_UNLIMITED_NUMBER;
4181         break;
4182     case OP_KVHSLICE:
4183     case OP_KVASLICE:
4184     case OP_AKEYS:
4185         if (type == OP_LEAVESUBLV)
4186             o->op_private |= OPpMAYBE_LVSUB;
4187         goto nomod;
4188     case OP_AVHVSWITCH:
4189         if (type == OP_LEAVESUBLV
4190          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
4191             o->op_private |= OPpMAYBE_LVSUB;
4192         goto nomod;
4193     case OP_AV2ARYLEN:
4194         PL_hints |= HINT_BLOCK_SCOPE;
4195         if (type == OP_LEAVESUBLV)
4196             o->op_private |= OPpMAYBE_LVSUB;
4197         PL_modcount++;
4198         break;
4199     case OP_RV2SV:
4200         ref(cUNOPo->op_first, o->op_type);
4201         localize = 1;
4202         /* FALLTHROUGH */
4203     case OP_GV:
4204         PL_hints |= HINT_BLOCK_SCOPE;
4205         /* FALLTHROUGH */
4206     case OP_SASSIGN:
4207     case OP_ANDASSIGN:
4208     case OP_ORASSIGN:
4209     case OP_DORASSIGN:
4210         PL_modcount++;
4211         break;
4212
4213     case OP_AELEMFAST:
4214     case OP_AELEMFAST_LEX:
4215         localize = -1;
4216         PL_modcount++;
4217         break;
4218
4219     case OP_PADAV:
4220     case OP_PADHV:
4221        PL_modcount = RETURN_UNLIMITED_NUMBER;
4222         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
4223         {
4224            /* Treat \(@foo) like ordinary list, but still mark it as modi-
4225               fiable since some contexts need to know.  */
4226             o->op_flags |= OPf_MOD;
4227             return o;
4228         }
4229         if (scalar_mod_type(o, type))
4230             goto nomod;
4231         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
4232           && type == OP_LEAVESUBLV)
4233             o->op_private |= OPpMAYBE_LVSUB;
4234         /* FALLTHROUGH */
4235     case OP_PADSV:
4236         PL_modcount++;
4237         if (!type) /* local() */
4238             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
4239                               PNfARG(PAD_COMPNAME(o->op_targ)));
4240         if (!(o->op_private & OPpLVAL_INTRO)
4241          || (  type != OP_SASSIGN && type != OP_AASSIGN
4242             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
4243             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
4244         break;
4245
4246     case OP_PUSHMARK:
4247         localize = 0;
4248         break;
4249
4250     case OP_KEYS:
4251         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
4252             goto nomod;
4253         goto lvalue_func;
4254     case OP_SUBSTR:
4255         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
4256             goto nomod;
4257         /* FALLTHROUGH */
4258     case OP_POS:
4259     case OP_VEC:
4260       lvalue_func:
4261         if (type == OP_LEAVESUBLV)
4262             o->op_private |= OPpMAYBE_LVSUB;
4263         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
4264             /* substr and vec */
4265             /* If this op is in merely potential (non-fatal) modifiable
4266                context, then apply OP_ENTERSUB context to
4267                the kid op (to avoid croaking).  Other-
4268                wise pass this op’s own type so the correct op is mentioned
4269                in error messages.  */
4270             op_lvalue(OpSIBLING(cBINOPo->op_first),
4271                       S_potential_mod_type(type)
4272                         ? (I32)OP_ENTERSUB
4273                         : o->op_type);
4274         }
4275         break;
4276
4277     case OP_AELEM:
4278     case OP_HELEM:
4279         ref(cBINOPo->op_first, o->op_type);
4280         if (type == OP_ENTERSUB &&
4281              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
4282             o->op_private |= OPpLVAL_DEFER;
4283         if (type == OP_LEAVESUBLV)
4284             o->op_private |= OPpMAYBE_LVSUB;
4285         localize = 1;
4286         PL_modcount++;
4287         break;
4288
4289     case OP_LEAVE:
4290     case OP_LEAVELOOP:
4291         o->op_private |= OPpLVALUE;
4292         /* FALLTHROUGH */
4293     case OP_SCOPE:
4294     case OP_ENTER:
4295     case OP_LINESEQ:
4296         localize = 0;
4297         if (o->op_flags & OPf_KIDS)
4298             op_lvalue(cLISTOPo->op_last, type);
4299         break;
4300
4301     case OP_NULL:
4302         localize = 0;
4303         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
4304             goto nomod;
4305         else if (!(o->op_flags & OPf_KIDS))
4306             break;
4307
4308         if (o->op_targ != OP_LIST) {
4309             OP *sib = OpSIBLING(cLISTOPo->op_first);
4310             /* OP_TRANS and OP_TRANSR with argument have a weird optree
4311              * that looks like
4312              *
4313              *   null
4314              *      arg
4315              *      trans
4316              *
4317              * compared with things like OP_MATCH which have the argument
4318              * as a child:
4319              *
4320              *   match
4321              *      arg
4322              *
4323              * so handle specially to correctly get "Can't modify" croaks etc
4324              */
4325
4326             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
4327             {
4328                 /* this should trigger a "Can't modify transliteration" err */
4329                 op_lvalue(sib, type);
4330             }
4331             op_lvalue(cBINOPo->op_first, type);
4332             break;
4333         }
4334         /* FALLTHROUGH */
4335     case OP_LIST:
4336         localize = 0;
4337         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4338             /* elements might be in void context because the list is
4339                in scalar context or because they are attribute sub calls */
4340             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
4341                 op_lvalue(kid, type);
4342         break;
4343
4344     case OP_COREARGS:
4345         return o;
4346
4347     case OP_AND:
4348     case OP_OR:
4349         if (type == OP_LEAVESUBLV
4350          || !S_vivifies(cLOGOPo->op_first->op_type))
4351             op_lvalue(cLOGOPo->op_first, type);
4352         if (type == OP_LEAVESUBLV
4353          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
4354             op_lvalue(OpSIBLING(cLOGOPo->op_first), type);
4355         goto nomod;
4356
4357     case OP_SREFGEN:
4358         if (type == OP_NULL) { /* local */
4359           local_refgen:
4360             if (!FEATURE_MYREF_IS_ENABLED)
4361                 Perl_croak(aTHX_ "The experimental declared_refs "
4362                                  "feature is not enabled");
4363             Perl_ck_warner_d(aTHX_
4364                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4365                     "Declaring references is experimental");
4366             op_lvalue(cUNOPo->op_first, OP_NULL);
4367             return o;
4368         }
4369         if (type != OP_AASSIGN && type != OP_SASSIGN
4370          && type != OP_ENTERLOOP)
4371             goto nomod;
4372         /* Don’t bother applying lvalue context to the ex-list.  */
4373         kid = cUNOPx(cUNOPo->op_first)->op_first;
4374         assert (!OpHAS_SIBLING(kid));
4375         goto kid_2lvref;
4376     case OP_REFGEN:
4377         if (type == OP_NULL) /* local */
4378             goto local_refgen;
4379         if (type != OP_AASSIGN) goto nomod;
4380         kid = cUNOPo->op_first;
4381       kid_2lvref:
4382         {
4383             const U8 ec = PL_parser ? PL_parser->error_count : 0;
4384             S_lvref(aTHX_ kid, type);
4385             if (!PL_parser || PL_parser->error_count == ec) {
4386                 if (!FEATURE_REFALIASING_IS_ENABLED)
4387                     Perl_croak(aTHX_
4388                        "Experimental aliasing via reference not enabled");
4389                 Perl_ck_warner_d(aTHX_
4390                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
4391                                 "Aliasing via reference is experimental");
4392             }
4393         }
4394         if (o->op_type == OP_REFGEN)
4395             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
4396         op_null(o);
4397         return o;
4398
4399     case OP_SPLIT:
4400         if ((o->op_private & OPpSPLIT_ASSIGN)) {
4401             /* This is actually @array = split.  */
4402             PL_modcount = RETURN_UNLIMITED_NUMBER;
4403             break;
4404         }
4405         goto nomod;
4406
4407     case OP_SCALAR:
4408         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
4409         goto nomod;
4410     }
4411
4412     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
4413        their argument is a filehandle; thus \stat(".") should not set
4414        it. AMS 20011102 */
4415     if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
4416         return o;
4417
4418     if (type != OP_LEAVESUBLV)
4419         o->op_flags |= OPf_MOD;
4420
4421     if (type == OP_AASSIGN || type == OP_SASSIGN)
4422         o->op_flags |= OPf_SPECIAL
4423                       |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
4424     else if (!type) { /* local() */
4425         switch (localize) {
4426         case 1:
4427             o->op_private |= OPpLVAL_INTRO;
4428             o->op_flags &= ~OPf_SPECIAL;
4429             PL_hints |= HINT_BLOCK_SCOPE;
4430             break;
4431         case 0:
4432             break;
4433         case -1:
4434             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
4435                            "Useless localization of %s", OP_DESC(o));
4436         }
4437     }
4438     else if (type != OP_GREPSTART && type != OP_ENTERSUB
4439              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
4440         o->op_flags |= OPf_REF;
4441     return o;
4442 }
4443
4444 STATIC bool
4445 S_scalar_mod_type(const OP *o, I32 type)
4446 {
4447     switch (type) {
4448     case OP_POS:
4449     case OP_SASSIGN:
4450         if (o && o->op_type == OP_RV2GV)
4451             return FALSE;
4452         /* FALLTHROUGH */
4453     case OP_PREINC:
4454     case OP_PREDEC:
4455     case OP_POSTINC:
4456     case OP_POSTDEC:
4457     case OP_I_PREINC:
4458     case OP_I_PREDEC:
4459     case OP_I_POSTINC:
4460     case OP_I_POSTDEC:
4461     case OP_POW:
4462     case OP_MULTIPLY:
4463     case OP_DIVIDE:
4464     case OP_MODULO:
4465     case OP_REPEAT:
4466     case OP_ADD:
4467     case OP_SUBTRACT:
4468     case OP_I_MULTIPLY:
4469     case OP_I_DIVIDE:
4470     case OP_I_MODULO:
4471     case OP_I_ADD:
4472     case OP_I_SUBTRACT:
4473     case OP_LEFT_SHIFT:
4474     case OP_RIGHT_SHIFT:
4475     case OP_BIT_AND:
4476     case OP_BIT_XOR:
4477     case OP_BIT_OR:
4478     case OP_NBIT_AND:
4479     case OP_NBIT_XOR:
4480     case OP_NBIT_OR:
4481     case OP_SBIT_AND:
4482     case OP_SBIT_XOR:
4483     case OP_SBIT_OR:
4484     case OP_CONCAT:
4485     case OP_SUBST:
4486     case OP_TRANS:
4487     case OP_TRANSR:
4488     case OP_READ:
4489     case OP_SYSREAD:
4490     case OP_RECV:
4491     case OP_ANDASSIGN:
4492     case OP_ORASSIGN:
4493     case OP_DORASSIGN:
4494     case OP_VEC:
4495     case OP_SUBSTR:
4496         return TRUE;
4497     default:
4498         return FALSE;
4499     }
4500 }
4501
4502 STATIC bool
4503 S_is_handle_constructor(const OP *o, I32 numargs)
4504 {
4505     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
4506
4507     switch (o->op_type) {
4508     case OP_PIPE_OP:
4509     case OP_SOCKPAIR:
4510         if (numargs == 2)
4511             return TRUE;
4512         /* FALLTHROUGH */
4513     case OP_SYSOPEN:
4514     case OP_OPEN:
4515     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
4516     case OP_SOCKET:
4517     case OP_OPEN_DIR:
4518     case OP_ACCEPT:
4519         if (numargs == 1)
4520             return TRUE;
4521         /* FALLTHROUGH */
4522     default:
4523         return FALSE;
4524     }
4525 }
4526
4527 static OP *
4528 S_refkids(pTHX_ OP *o, I32 type)
4529 {
4530     if (o && o->op_flags & OPf_KIDS) {
4531         OP *kid;
4532         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4533             ref(kid, type);
4534     }
4535     return o;
4536 }
4537
4538 OP *
4539 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
4540 {
4541     dVAR;
4542     OP *kid;
4543
4544     PERL_ARGS_ASSERT_DOREF;
4545
4546     if (PL_parser && PL_parser->error_count)
4547         return o;
4548
4549     switch (o->op_type) {
4550     case OP_ENTERSUB:
4551         if ((type == OP_EXISTS || type == OP_DEFINED) &&
4552             !(o->op_flags & OPf_STACKED)) {
4553             OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
4554             assert(cUNOPo->op_first->op_type == OP_NULL);
4555             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
4556             o->op_flags |= OPf_SPECIAL;
4557         }
4558         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
4559             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4560                               : type == OP_RV2HV ? OPpDEREF_HV
4561                               : OPpDEREF_SV);
4562             o->op_flags |= OPf_MOD;
4563         }
4564
4565         break;
4566
4567     case OP_COND_EXPR:
4568         for (kid = OpSIBLING(cUNOPo->op_first); kid; kid = OpSIBLING(kid))
4569             doref(kid, type, set_op_ref);
4570         break;
4571     case OP_RV2SV:
4572         if (type == OP_DEFINED)
4573             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4574         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4575         /* FALLTHROUGH */
4576     case OP_PADSV:
4577         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4578             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4579                               : type == OP_RV2HV ? OPpDEREF_HV
4580                               : OPpDEREF_SV);
4581             o->op_flags |= OPf_MOD;
4582         }
4583         break;
4584
4585     case OP_RV2AV:
4586     case OP_RV2HV:
4587         if (set_op_ref)
4588             o->op_flags |= OPf_REF;
4589         /* FALLTHROUGH */
4590     case OP_RV2GV:
4591         if (type == OP_DEFINED)
4592             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
4593         doref(cUNOPo->op_first, o->op_type, set_op_ref);
4594         break;
4595
4596     case OP_PADAV:
4597     case OP_PADHV:
4598         if (set_op_ref)
4599             o->op_flags |= OPf_REF;
4600         break;
4601
4602     case OP_SCALAR:
4603     case OP_NULL:
4604         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
4605             break;
4606         doref(cBINOPo->op_first, type, set_op_ref);
4607         break;
4608     case OP_AELEM:
4609     case OP_HELEM:
4610         doref(cBINOPo->op_first, o->op_type, set_op_ref);
4611         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
4612             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
4613                               : type == OP_RV2HV ? OPpDEREF_HV
4614                               : OPpDEREF_SV);
4615             o->op_flags |= OPf_MOD;
4616         }
4617         break;
4618
4619     case OP_SCOPE:
4620     case OP_LEAVE:
4621         set_op_ref = FALSE;
4622         /* FALLTHROUGH */
4623     case OP_ENTER:
4624     case OP_LIST:
4625         if (!(o->op_flags & OPf_KIDS))
4626             break;
4627         doref(cLISTOPo->op_last, type, set_op_ref);
4628         break;
4629     default:
4630         break;
4631     }
4632     return scalar(o);
4633
4634 }
4635
4636 STATIC OP *
4637 S_dup_attrlist(pTHX_ OP *o)
4638 {
4639     OP *rop;
4640
4641     PERL_ARGS_ASSERT_DUP_ATTRLIST;
4642
4643     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
4644      * where the first kid is OP_PUSHMARK and the remaining ones
4645      * are OP_CONST.  We need to push the OP_CONST values.
4646      */
4647     if (o->op_type == OP_CONST)
4648         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
4649     else {
4650         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
4651         rop = NULL;
4652         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
4653             if (o->op_type == OP_CONST)
4654                 rop = op_append_elem(OP_LIST, rop,
4655                                   newSVOP(OP_CONST, o->op_flags,
4656                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
4657         }
4658     }
4659     return rop;
4660 }
4661
4662 STATIC void
4663 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
4664 {
4665     PERL_ARGS_ASSERT_APPLY_ATTRS;
4666     {
4667         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
4668
4669         /* fake up C<use attributes $pkg,$rv,@attrs> */
4670
4671 #define ATTRSMODULE "attributes"
4672 #define ATTRSMODULE_PM "attributes.pm"
4673
4674         Perl_load_module(
4675           aTHX_ PERL_LOADMOD_IMPORT_OPS,
4676           newSVpvs(ATTRSMODULE),
4677           NULL,
4678           op_prepend_elem(OP_LIST,
4679                           newSVOP(OP_CONST, 0, stashsv),
4680                           op_prepend_elem(OP_LIST,
4681                                           newSVOP(OP_CONST, 0,
4682                                                   newRV(target)),
4683                                           dup_attrlist(attrs))));
4684     }
4685 }
4686
4687 STATIC void
4688 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
4689 {
4690     OP *pack, *imop, *arg;
4691     SV *meth, *stashsv, **svp;
4692
4693     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
4694
4695     if (!attrs)
4696         return;
4697
4698     assert(target->op_type == OP_PADSV ||
4699            target->op_type == OP_PADHV ||
4700            target->op_type == OP_PADAV);
4701
4702     /* Ensure that attributes.pm is loaded. */
4703     /* Don't force the C<use> if we don't need it. */
4704     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
4705     if (svp && *svp != &PL_sv_undef)
4706         NOOP;   /* already in %INC */
4707     else
4708         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
4709                                newSVpvs(ATTRSMODULE), NULL);
4710
4711     /* Need package name for method call. */
4712     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
4713
4714     /* Build up the real arg-list. */
4715     stashsv = newSVhek(HvNAME_HEK(stash));
4716
4717     arg = newOP(OP_PADSV, 0);
4718     arg->op_targ = target->op_targ;
4719     arg = op_prepend_elem(OP_LIST,
4720                        newSVOP(OP_CONST, 0, stashsv),
4721                        op_prepend_elem(OP_LIST,
4722                                     newUNOP(OP_REFGEN, 0,
4723                                             arg),
4724                                     dup_attrlist(attrs)));
4725
4726     /* Fake up a method call to import */
4727     meth = newSVpvs_share("import");
4728     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
4729                    op_append_elem(OP_LIST,
4730                                op_prepend_elem(OP_LIST, pack, arg),
4731                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));