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