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