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