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