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