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