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