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