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