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