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