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