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