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