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