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