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