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