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