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