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