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