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