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