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