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