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