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