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