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