bdaf3244ecd648e9c8a96365d7cb53d6f6753a48
[perl.git] / op.c
1 #line 2 "op.c"
2 /*    op.c
3  *
4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6  *
7  *    You may distribute under the terms of either the GNU General Public
8  *    License or the Artistic License, as specified in the README file.
9  *
10  */
11
12 /*
13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
17  *  either way, as the saying is, if you follow me.'       --the Gaffer
18  *
19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20  */
21
22 /* This file contains the functions that create, manipulate and optimize
23  * the OP structures that hold a compiled perl program.
24  *
25  * A Perl program is compiled into a tree of OPs. Each op contains
26  * structural pointers (eg to its siblings and the next op in the
27  * execution sequence), a pointer to the function that would execute the
28  * op, plus any data specific to that op. For example, an OP_CONST op
29  * points to the pp_const() function and to an SV containing the constant
30  * value. When pp_const() is executed, its job is to push that SV onto the
31  * stack.
32  *
33  * OPs are mainly created by the newFOO() functions, which are mainly
34  * called from the parser (in perly.y) as the code is parsed. For example
35  * the Perl code $a + $b * $c would cause the equivalent of the following
36  * to be called (oversimplifying a bit):
37  *
38  *  newBINOP(OP_ADD, flags,
39  *      newSVREF($a),
40  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41  *  )
42  *
43  * Note that during the build of miniperl, a temporary copy of this file
44  * is made, called opmini.c.
45  */
46
47 /*
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50     A bottom-up pass
51     A top-down pass
52     An execution-order pass
53
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines.  The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order.  (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
61 top level node.)
62
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again).  As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node.  But
70 it's still not the real execution order.
71
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer.  At that point, we can call
75 into peep() to do that code's portion of the 3rd pass.  It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
77 */
78
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80    get the compile time state of %^H for that block.  Storing %^H in every
81    block (or even COP) would be very expensive, so a different approach is
82    taken.  The (running) state of %^H is serialised into a tree of HE-like
83    structs.  Stores into %^H are chained onto the current leaf as a struct
84    refcounted_he * with the key and the value.  Deletes from %^H are saved
85    with a value of PL_sv_placeholder.  The state of %^H at any point can be
86    turned back into a regular HV by walking back up the tree from that point's
87    leaf, ignoring any key you've already seen (placeholder or not), storing
88    the rest into the HV structure, then removing the placeholders. Hence
89    memory is only used to store the %^H deltas from the enclosing COP, rather
90    than the entire %^H on each COP.
91
92    To cause actions on %^H to write out the serialisation records, it has
93    magic type 'H'. This magic (itself) does nothing, but its presence causes
94    the values to gain magic type 'h', which has entries for set and clear.
95    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98    it will be correctly restored when any inner compiling scope is exited.
99 */
100
101 #include "EXTERN.h"
102 #define PERL_IN_OP_C
103 #include "perl.h"
104 #include "keywords.h"
105 #include "feature.h"
106 #include "regcomp.h"
107
108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
111
112 /* 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     {
198         o = (OP*)PerlMemShared_calloc(1, sz);
199         goto gotit;
200     }
201
202     /* While the subroutine is under construction, the slabs are accessed via
203        CvSTART(), to avoid needing to expand PVCV by one pointer for something
204        unneeded at runtime. Once a subroutine is constructed, the slabs are
205        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
206        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
207        details.  */
208     if (!CvSTART(PL_compcv)) {
209         CvSTART(PL_compcv) =
210             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
211         CvSLABBED_on(PL_compcv);
212         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
213     }
214     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
215
216     opsz = SIZE_TO_PSIZE(sz);
217     sz = opsz + OPSLOT_HEADER_P;
218
219     /* The slabs maintain a free list of OPs. In particular, constant folding
220        will free up OPs, so it makes sense to re-use them where possible. A
221        freed up slot is used in preference to a new allocation.  */
222     if (slab->opslab_freed) {
223         OP **too = &slab->opslab_freed;
224         o = *too;
225         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab));
226         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
227             DEBUG_S_warn((aTHX_ "Alas! too small"));
228             o = *(too = &o->op_next);
229             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); }
230         }
231         if (o) {
232             *too = o->op_next;
233             Zero(o, opsz, I32 *);
234             o->op_slabbed = 1;
235             goto gotit;
236         }
237     }
238
239 #define INIT_OPSLOT \
240             slot->opslot_slab = slab;                   \
241             slot->opslot_next = slab2->opslab_first;    \
242             slab2->opslab_first = slot;                 \
243             o = &slot->opslot_op;                       \
244             o->op_slabbed = 1
245
246     /* The partially-filled slab is next in the chain. */
247     slab2 = slab->opslab_next ? slab->opslab_next : slab;
248     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
249         /* Remaining space is too small. */
250
251         /* If we can fit a BASEOP, add it to the free chain, so as not
252            to waste it. */
253         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
254             slot = &slab2->opslab_slots;
255             INIT_OPSLOT;
256             o->op_type = OP_FREED;
257             o->op_next = slab->opslab_freed;
258             slab->opslab_freed = o;
259         }
260
261         /* Create a new slab.  Make this one twice as big. */
262         slot = slab2->opslab_first;
263         while (slot->opslot_next) slot = slot->opslot_next;
264         slab2 = S_new_slab(aTHX_
265                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
266                                         ? PERL_MAX_SLAB_SIZE
267                                         : (DIFF(slab2, slot)+1)*2);
268         slab2->opslab_next = slab->opslab_next;
269         slab->opslab_next = slab2;
270     }
271     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
272
273     /* Create a new op slot */
274     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
275     assert(slot >= &slab2->opslab_slots);
276     if (DIFF(&slab2->opslab_slots, slot)
277          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
278         slot = &slab2->opslab_slots;
279     INIT_OPSLOT;
280     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
281
282   gotit:
283     /* lastsib == 1, op_sibling == 0 implies a solitary unattached op */
284     o->op_lastsib = 1;
285     assert(!o->op_sibling);
286
287     return (void *)o;
288 }
289
290 #undef INIT_OPSLOT
291
292 #ifdef PERL_DEBUG_READONLY_OPS
293 void
294 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
295 {
296     PERL_ARGS_ASSERT_SLAB_TO_RO;
297
298     if (slab->opslab_readonly) return;
299     slab->opslab_readonly = 1;
300     for (; slab; slab = slab->opslab_next) {
301         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
302                               (unsigned long) slab->opslab_size, slab));*/
303         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
304             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
305                              (unsigned long)slab->opslab_size, errno);
306     }
307 }
308
309 void
310 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
311 {
312     OPSLAB *slab2;
313
314     PERL_ARGS_ASSERT_SLAB_TO_RW;
315
316     if (!slab->opslab_readonly) return;
317     slab2 = slab;
318     for (; slab2; slab2 = slab2->opslab_next) {
319         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
320                               (unsigned long) size, slab2));*/
321         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
322                      PROT_READ|PROT_WRITE)) {
323             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
324                              (unsigned long)slab2->opslab_size, errno);
325         }
326     }
327     slab->opslab_readonly = 0;
328 }
329
330 #else
331 #  define Slab_to_rw(op)    NOOP
332 #endif
333
334 /* This cannot possibly be right, but it was copied from the old slab
335    allocator, to which it was originally added, without explanation, in
336    commit 083fcd5. */
337 #ifdef NETWARE
338 #    define PerlMemShared PerlMem
339 #endif
340
341 void
342 Perl_Slab_Free(pTHX_ void *op)
343 {
344     OP * const o = (OP *)op;
345     OPSLAB *slab;
346
347     PERL_ARGS_ASSERT_SLAB_FREE;
348
349     if (!o->op_slabbed) {
350         if (!o->op_static)
351             PerlMemShared_free(op);
352         return;
353     }
354
355     slab = OpSLAB(o);
356     /* If this op is already freed, our refcount will get screwy. */
357     assert(o->op_type != OP_FREED);
358     o->op_type = OP_FREED;
359     o->op_next = slab->opslab_freed;
360     slab->opslab_freed = o;
361     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab));
362     OpslabREFCNT_dec_padok(slab);
363 }
364
365 void
366 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
367 {
368     const bool havepad = !!PL_comppad;
369     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
370     if (havepad) {
371         ENTER;
372         PAD_SAVE_SETNULLPAD();
373     }
374     opslab_free(slab);
375     if (havepad) LEAVE;
376 }
377
378 void
379 Perl_opslab_free(pTHX_ OPSLAB *slab)
380 {
381     OPSLAB *slab2;
382     PERL_ARGS_ASSERT_OPSLAB_FREE;
383     PERL_UNUSED_CONTEXT;
384     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
385     assert(slab->opslab_refcnt == 1);
386     for (; slab; slab = slab2) {
387         slab2 = slab->opslab_next;
388 #ifdef DEBUGGING
389         slab->opslab_refcnt = ~(size_t)0;
390 #endif
391 #ifdef PERL_DEBUG_READONLY_OPS
392         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
393                                                (void*)slab));
394         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
395             perror("munmap failed");
396             abort();
397         }
398 #else
399         PerlMemShared_free(slab);
400 #endif
401     }
402 }
403
404 void
405 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
406 {
407     OPSLAB *slab2;
408     OPSLOT *slot;
409 #ifdef DEBUGGING
410     size_t savestack_count = 0;
411 #endif
412     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
413     slab2 = slab;
414     do {
415         for (slot = slab2->opslab_first;
416              slot->opslot_next;
417              slot = slot->opslot_next) {
418             if (slot->opslot_op.op_type != OP_FREED
419              && !(slot->opslot_op.op_savefree
420 #ifdef DEBUGGING
421                   && ++savestack_count
422 #endif
423                  )
424             ) {
425                 assert(slot->opslot_op.op_slabbed);
426                 op_free(&slot->opslot_op);
427                 if (slab->opslab_refcnt == 1) goto free;
428             }
429         }
430     } while ((slab2 = slab2->opslab_next));
431     /* > 1 because the CV still holds a reference count. */
432     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
433 #ifdef DEBUGGING
434         assert(savestack_count == slab->opslab_refcnt-1);
435 #endif
436         /* Remove the CV’s reference count. */
437         slab->opslab_refcnt--;
438         return;
439     }
440    free:
441     opslab_free(slab);
442 }
443
444 #ifdef PERL_DEBUG_READONLY_OPS
445 OP *
446 Perl_op_refcnt_inc(pTHX_ OP *o)
447 {
448     if(o) {
449         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
450         if (slab && slab->opslab_readonly) {
451             Slab_to_rw(slab);
452             ++o->op_targ;
453             Slab_to_ro(slab);
454         } else {
455             ++o->op_targ;
456         }
457     }
458     return o;
459
460 }
461
462 PADOFFSET
463 Perl_op_refcnt_dec(pTHX_ OP *o)
464 {
465     PADOFFSET result;
466     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
467
468     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
469
470     if (slab && slab->opslab_readonly) {
471         Slab_to_rw(slab);
472         result = --o->op_targ;
473         Slab_to_ro(slab);
474     } else {
475         result = --o->op_targ;
476     }
477     return result;
478 }
479 #endif
480 /*
481  * In the following definition, the ", (OP*)0" is just to make the compiler
482  * think the expression is of the right type: croak actually does a Siglongjmp.
483  */
484 #define CHECKOP(type,o) \
485     ((PL_op_mask && PL_op_mask[type])                           \
486      ? ( op_free((OP*)o),                                       \
487          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
488          (OP*)0 )                                               \
489      : PL_check[type](aTHX_ (OP*)o))
490
491 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
492
493 #define CHANGE_TYPE(o,type) \
494     STMT_START {                                \
495         o->op_type = (OPCODE)type;              \
496         o->op_ppaddr = PL_ppaddr[type];         \
497     } STMT_END
498
499 STATIC OP *
500 S_no_fh_allowed(pTHX_ OP *o)
501 {
502     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
503
504     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
505                  OP_DESC(o)));
506     return o;
507 }
508
509 STATIC OP *
510 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
511 {
512     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
513     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
514     return o;
515 }
516  
517 STATIC OP *
518 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
519 {
520     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
521
522     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
523     return o;
524 }
525
526 STATIC void
527 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
528 {
529     PERL_ARGS_ASSERT_BAD_TYPE_PV;
530
531     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
532                  (int)n, name, t, OP_DESC(kid)), flags);
533 }
534
535 STATIC void
536 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
537 {
538     SV * const namesv = cv_name((CV *)gv, NULL, 0);
539     PERL_ARGS_ASSERT_BAD_TYPE_GV;
540  
541     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
542                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
543 }
544
545 STATIC void
546 S_no_bareword_allowed(pTHX_ OP *o)
547 {
548     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
549
550     qerror(Perl_mess(aTHX_
551                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
552                      SVfARG(cSVOPo_sv)));
553     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
554 }
555
556 /* "register" allocation */
557
558 PADOFFSET
559 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
560 {
561     PADOFFSET off;
562     const bool is_our = (PL_parser->in_my == KEY_our);
563
564     PERL_ARGS_ASSERT_ALLOCMY;
565
566     if (flags & ~SVf_UTF8)
567         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
568                    (UV)flags);
569
570     /* complain about "my $<special_var>" etc etc */
571     if (len &&
572         !(is_our ||
573           isALPHA(name[1]) ||
574           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
575           (name[1] == '_' && (*name == '$' || len > 2))))
576     {
577         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
578          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
579             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
580                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
581                               PL_parser->in_my == KEY_state ? "state" : "my"));
582         } else {
583             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
584                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
585         }
586     }
587     else if (len == 2 && name[1] == '_' && !is_our)
588         /* diag_listed_as: Use of my $_ is experimental */
589         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
590                               "Use of %s $_ is experimental",
591                                PL_parser->in_my == KEY_state
592                                  ? "state"
593                                  : "my");
594
595     /* allocate a spare slot and store the name in that slot */
596
597     off = pad_add_name_pvn(name, len,
598                        (is_our ? padadd_OUR :
599                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
600                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
601                     PL_parser->in_my_stash,
602                     (is_our
603                         /* $_ is always in main::, even with our */
604                         ? (PL_curstash && !memEQs(name,len,"$_")
605                             ? PL_curstash
606                             : PL_defstash)
607                         : NULL
608                     )
609     );
610     /* anon sub prototypes contains state vars should always be cloned,
611      * otherwise the state var would be shared between anon subs */
612
613     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
614         CvCLONE_on(PL_compcv);
615
616     return off;
617 }
618
619 /*
620 =head1 Optree Manipulation Functions
621
622 =for apidoc alloccopstash
623
624 Available only under threaded builds, this function allocates an entry in
625 C<PL_stashpad> for the stash passed to it.
626
627 =cut
628 */
629
630 #ifdef USE_ITHREADS
631 PADOFFSET
632 Perl_alloccopstash(pTHX_ HV *hv)
633 {
634     PADOFFSET off = 0, o = 1;
635     bool found_slot = FALSE;
636
637     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
638
639     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
640
641     for (; o < PL_stashpadmax; ++o) {
642         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
643         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
644             found_slot = TRUE, off = o;
645     }
646     if (!found_slot) {
647         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
648         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
649         off = PL_stashpadmax;
650         PL_stashpadmax += 10;
651     }
652
653     PL_stashpad[PL_stashpadix = off] = hv;
654     return off;
655 }
656 #endif
657
658 /* free the body of an op without examining its contents.
659  * Always use this rather than FreeOp directly */
660
661 static void
662 S_op_destroy(pTHX_ OP *o)
663 {
664     FreeOp(o);
665 }
666
667 /* Destructor */
668
669 /*
670 =for apidoc Am|void|op_free|OP *o
671
672 Free an op.  Only use this when an op is no longer linked to from any
673 optree.
674
675 =cut
676 */
677
678 void
679 Perl_op_free(pTHX_ OP *o)
680 {
681     dVAR;
682     OPCODE type;
683
684     /* Though ops may be freed twice, freeing the op after its slab is a
685        big no-no. */
686     assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0); 
687     /* During the forced freeing of ops after compilation failure, kidops
688        may be freed before their parents. */
689     if (!o || o->op_type == OP_FREED)
690         return;
691
692     type = o->op_type;
693
694     /* an op should only ever acquire op_private flags that we know about.
695      * If this fails, you may need to fix something in regen/op_private */
696     if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
697         assert(!(o->op_private & ~PL_op_private_valid[type]));
698     }
699
700     if (o->op_private & OPpREFCOUNTED) {
701         switch (type) {
702         case OP_LEAVESUB:
703         case OP_LEAVESUBLV:
704         case OP_LEAVEEVAL:
705         case OP_LEAVE:
706         case OP_SCOPE:
707         case OP_LEAVEWRITE:
708             {
709             PADOFFSET refcnt;
710             OP_REFCNT_LOCK;
711             refcnt = OpREFCNT_dec(o);
712             OP_REFCNT_UNLOCK;
713             if (refcnt) {
714                 /* Need to find and remove any pattern match ops from the list
715                    we maintain for reset().  */
716                 find_and_forget_pmops(o);
717                 return;
718             }
719             }
720             break;
721         default:
722             break;
723         }
724     }
725
726     /* Call the op_free hook if it has been set. Do it now so that it's called
727      * at the right time for refcounted ops, but still before all of the kids
728      * are freed. */
729     CALL_OPFREEHOOK(o);
730
731     if (o->op_flags & OPf_KIDS) {
732         OP *kid, *nextkid;
733         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
734             nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
735             op_free(kid);
736         }
737     }
738     if (type == OP_NULL)
739         type = (OPCODE)o->op_targ;
740
741     if (o->op_slabbed)
742         Slab_to_rw(OpSLAB(o));
743
744     /* COP* is not cleared by op_clear() so that we may track line
745      * numbers etc even after null() */
746     if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
747         cop_free((COP*)o);
748     }
749
750     op_clear(o);
751     FreeOp(o);
752 #ifdef DEBUG_LEAKING_SCALARS
753     if (PL_op == o)
754         PL_op = NULL;
755 #endif
756 }
757
758 void
759 Perl_op_clear(pTHX_ OP *o)
760 {
761
762     dVAR;
763
764     PERL_ARGS_ASSERT_OP_CLEAR;
765
766     switch (o->op_type) {
767     case OP_NULL:       /* Was holding old type, if any. */
768         /* FALLTHROUGH */
769     case OP_ENTERTRY:
770     case OP_ENTEREVAL:  /* Was holding hints. */
771         o->op_targ = 0;
772         break;
773     default:
774         if (!(o->op_flags & OPf_REF)
775             || (PL_check[o->op_type] != Perl_ck_ftst))
776             break;
777         /* FALLTHROUGH */
778     case OP_GVSV:
779     case OP_GV:
780     case OP_AELEMFAST:
781         {
782             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
783 #ifdef USE_ITHREADS
784                         && PL_curpad
785 #endif
786                         ? cGVOPo_gv : NULL;
787             /* It's possible during global destruction that the GV is freed
788                before the optree. Whilst the SvREFCNT_inc is happy to bump from
789                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
790                will trigger an assertion failure, because the entry to sv_clear
791                checks that the scalar is not already freed.  A check of for
792                !SvIS_FREED(gv) turns out to be invalid, because during global
793                destruction the reference count can be forced down to zero
794                (with SVf_BREAK set).  In which case raising to 1 and then
795                dropping to 0 triggers cleanup before it should happen.  I
796                *think* that this might actually be a general, systematic,
797                weakness of the whole idea of SVf_BREAK, in that code *is*
798                allowed to raise and lower references during global destruction,
799                so any *valid* code that happens to do this during global
800                destruction might well trigger premature cleanup.  */
801             bool still_valid = gv && SvREFCNT(gv);
802
803             if (still_valid)
804                 SvREFCNT_inc_simple_void(gv);
805 #ifdef USE_ITHREADS
806             if (cPADOPo->op_padix > 0) {
807                 pad_swipe(cPADOPo->op_padix, TRUE);
808                 cPADOPo->op_padix = 0;
809             }
810 #else
811             SvREFCNT_dec(cSVOPo->op_sv);
812             cSVOPo->op_sv = NULL;
813 #endif
814             if (still_valid) {
815                 int try_downgrade = SvREFCNT(gv) == 2;
816                 SvREFCNT_dec_NN(gv);
817                 if (try_downgrade)
818                     gv_try_downgrade(gv);
819             }
820         }
821         break;
822     case OP_METHOD_NAMED:
823         SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
824         cMETHOPx(o)->op_u.op_meth_sv = NULL;
825 #ifdef USE_ITHREADS
826         if (o->op_targ) {
827             pad_swipe(o->op_targ, 1);
828             o->op_targ = 0;
829         }
830 #endif
831         break;
832     case OP_CONST:
833     case OP_HINTSEVAL:
834         SvREFCNT_dec(cSVOPo->op_sv);
835         cSVOPo->op_sv = NULL;
836 #ifdef USE_ITHREADS
837         /** Bug #15654
838           Even if op_clear does a pad_free for the target of the op,
839           pad_free doesn't actually remove the sv that exists in the pad;
840           instead it lives on. This results in that it could be reused as 
841           a target later on when the pad was reallocated.
842         **/
843         if(o->op_targ) {
844           pad_swipe(o->op_targ,1);
845           o->op_targ = 0;
846         }
847 #endif
848         break;
849     case OP_DUMP:
850     case OP_GOTO:
851     case OP_NEXT:
852     case OP_LAST:
853     case OP_REDO:
854         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
855             break;
856         /* FALLTHROUGH */
857     case OP_TRANS:
858     case OP_TRANSR:
859         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
860             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
861 #ifdef USE_ITHREADS
862             if (cPADOPo->op_padix > 0) {
863                 pad_swipe(cPADOPo->op_padix, TRUE);
864                 cPADOPo->op_padix = 0;
865             }
866 #else
867             SvREFCNT_dec(cSVOPo->op_sv);
868             cSVOPo->op_sv = NULL;
869 #endif
870         }
871         else {
872             PerlMemShared_free(cPVOPo->op_pv);
873             cPVOPo->op_pv = NULL;
874         }
875         break;
876     case OP_SUBST:
877         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
878         goto clear_pmop;
879     case OP_PUSHRE:
880 #ifdef USE_ITHREADS
881         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
882             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
883         }
884 #else
885         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
886 #endif
887         /* FALLTHROUGH */
888     case OP_MATCH:
889     case OP_QR:
890 clear_pmop:
891         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
892             op_free(cPMOPo->op_code_list);
893         cPMOPo->op_code_list = NULL;
894         forget_pmop(cPMOPo);
895         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
896         /* we use the same protection as the "SAFE" version of the PM_ macros
897          * here since sv_clean_all might release some PMOPs
898          * after PL_regex_padav has been cleared
899          * and the clearing of PL_regex_padav needs to
900          * happen before sv_clean_all
901          */
902 #ifdef USE_ITHREADS
903         if(PL_regex_pad) {        /* We could be in destruction */
904             const IV offset = (cPMOPo)->op_pmoffset;
905             ReREFCNT_dec(PM_GETRE(cPMOPo));
906             PL_regex_pad[offset] = &PL_sv_undef;
907             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
908                            sizeof(offset));
909         }
910 #else
911         ReREFCNT_dec(PM_GETRE(cPMOPo));
912         PM_SETRE(cPMOPo, NULL);
913 #endif
914
915         break;
916     }
917
918     if (o->op_targ > 0) {
919         pad_free(o->op_targ);
920         o->op_targ = 0;
921     }
922 }
923
924 STATIC void
925 S_cop_free(pTHX_ COP* cop)
926 {
927     PERL_ARGS_ASSERT_COP_FREE;
928
929     CopFILE_free(cop);
930     if (! specialWARN(cop->cop_warnings))
931         PerlMemShared_free(cop->cop_warnings);
932     cophh_free(CopHINTHASH_get(cop));
933     if (PL_curcop == cop)
934        PL_curcop = NULL;
935 }
936
937 STATIC void
938 S_forget_pmop(pTHX_ PMOP *const o
939               )
940 {
941     HV * const pmstash = PmopSTASH(o);
942
943     PERL_ARGS_ASSERT_FORGET_PMOP;
944
945     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
946         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
947         if (mg) {
948             PMOP **const array = (PMOP**) mg->mg_ptr;
949             U32 count = mg->mg_len / sizeof(PMOP**);
950             U32 i = count;
951
952             while (i--) {
953                 if (array[i] == o) {
954                     /* Found it. Move the entry at the end to overwrite it.  */
955                     array[i] = array[--count];
956                     mg->mg_len = count * sizeof(PMOP**);
957                     /* Could realloc smaller at this point always, but probably
958                        not worth it. Probably worth free()ing if we're the
959                        last.  */
960                     if(!count) {
961                         Safefree(mg->mg_ptr);
962                         mg->mg_ptr = NULL;
963                     }
964                     break;
965                 }
966             }
967         }
968     }
969     if (PL_curpm == o) 
970         PL_curpm = NULL;
971 }
972
973 STATIC void
974 S_find_and_forget_pmops(pTHX_ OP *o)
975 {
976     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
977
978     if (o->op_flags & OPf_KIDS) {
979         OP *kid = cUNOPo->op_first;
980         while (kid) {
981             switch (kid->op_type) {
982             case OP_SUBST:
983             case OP_PUSHRE:
984             case OP_MATCH:
985             case OP_QR:
986                 forget_pmop((PMOP*)kid);
987             }
988             find_and_forget_pmops(kid);
989             kid = OP_SIBLING(kid);
990         }
991     }
992 }
993
994 /*
995 =for apidoc Am|void|op_null|OP *o
996
997 Neutralizes an op when it is no longer needed, but is still linked to from
998 other ops.
999
1000 =cut
1001 */
1002
1003 void
1004 Perl_op_null(pTHX_ OP *o)
1005 {
1006     dVAR;
1007
1008     PERL_ARGS_ASSERT_OP_NULL;
1009
1010     if (o->op_type == OP_NULL)
1011         return;
1012     op_clear(o);
1013     o->op_targ = o->op_type;
1014     o->op_type = OP_NULL;
1015     o->op_ppaddr = PL_ppaddr[OP_NULL];
1016 }
1017
1018 void
1019 Perl_op_refcnt_lock(pTHX)
1020 {
1021 #ifdef USE_ITHREADS
1022     dVAR;
1023 #endif
1024     PERL_UNUSED_CONTEXT;
1025     OP_REFCNT_LOCK;
1026 }
1027
1028 void
1029 Perl_op_refcnt_unlock(pTHX)
1030 {
1031 #ifdef USE_ITHREADS
1032     dVAR;
1033 #endif
1034     PERL_UNUSED_CONTEXT;
1035     OP_REFCNT_UNLOCK;
1036 }
1037
1038
1039 /*
1040 =for apidoc op_sibling_splice
1041
1042 A general function for editing the structure of an existing chain of
1043 op_sibling nodes.  By analogy with the perl-level splice() function, allows
1044 you to delete zero or more sequential nodes, replacing them with zero or
1045 more different nodes.  Performs the necessary op_first/op_last
1046 housekeeping on the parent node and op_sibling manipulation on the
1047 children.  The last deleted node will be marked as as the last node by
1048 updating the op_sibling or op_lastsib field as appropriate.
1049
1050 Note that op_next is not manipulated, and nodes are not freed; that is the
1051 responsibility of the caller.  It also won't create a new list op for an
1052 empty list etc; use higher-level functions like op_append_elem() for that.
1053
1054 parent is the parent node of the sibling chain.
1055
1056 start is the node preceding the first node to be spliced.  Node(s)
1057 following it will be deleted, and ops will be inserted after it.  If it is
1058 NULL, the first node onwards is deleted, and nodes are inserted at the
1059 beginning.
1060
1061 del_count is the number of nodes to delete.  If zero, no nodes are deleted.
1062 If -1 or greater than or equal to the number of remaining kids, all
1063 remaining kids are deleted.
1064
1065 insert is the first of a chain of nodes to be inserted in place of the nodes.
1066 If NULL, no nodes are inserted.
1067
1068 The head of the chain of deleted ops is returned, or NULL if no ops were
1069 deleted.
1070
1071 For example:
1072
1073     action                    before      after         returns
1074     ------                    -----       -----         -------
1075
1076                               P           P
1077     splice(P, A, 2, X-Y-Z)    |           |             B-C
1078                               A-B-C-D     A-X-Y-Z-D
1079
1080                               P           P
1081     splice(P, NULL, 1, X-Y)   |           |             A
1082                               A-B-C-D     X-Y-B-C-D
1083
1084                               P           P
1085     splice(P, NULL, 3, NULL)  |           |             A-B-C
1086                               A-B-C-D     D
1087
1088                               P           P
1089     splice(P, B, 0, X-Y)      |           |             NULL
1090                               A-B-C-D     A-B-X-Y-C-D
1091
1092 =cut
1093 */
1094
1095 OP *
1096 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1097 {
1098     OP *first = start ? OP_SIBLING(start) : cLISTOPx(parent)->op_first;
1099     OP *rest;
1100     OP *last_del = NULL;
1101     OP *last_ins = NULL;
1102
1103     PERL_ARGS_ASSERT_OP_SIBLING_SPLICE;
1104
1105     assert(del_count >= -1);
1106
1107     if (del_count && first) {
1108         last_del = first;
1109         while (--del_count && OP_HAS_SIBLING(last_del))
1110             last_del = OP_SIBLING(last_del);
1111         rest = OP_SIBLING(last_del);
1112         OP_SIBLING_set(last_del, NULL);
1113         last_del->op_lastsib = 1;
1114     }
1115     else
1116         rest = first;
1117
1118     if (insert) {
1119         last_ins = insert;
1120         while (OP_HAS_SIBLING(last_ins))
1121             last_ins = OP_SIBLING(last_ins);
1122         OP_SIBLING_set(last_ins, rest);
1123         last_ins->op_lastsib = rest ? 0 : 1;
1124     }
1125     else
1126         insert = rest;
1127
1128     if (start) {
1129         OP_SIBLING_set(start, insert);
1130         start->op_lastsib = insert ? 0 : 1;
1131     }
1132     else
1133         cLISTOPx(parent)->op_first = insert;
1134
1135     if (!rest) {
1136         /* update op_last etc */
1137         U32 type = parent->op_type;
1138         OP *lastop;
1139
1140         if (type == OP_NULL)
1141             type = parent->op_targ;
1142         type = PL_opargs[type] & OA_CLASS_MASK;
1143
1144         lastop = last_ins ? last_ins : start ? start : NULL;
1145         if (   type == OA_BINOP
1146             || type == OA_LISTOP
1147             || type == OA_PMOP
1148             || type == OA_LOOP
1149         )
1150             cLISTOPx(parent)->op_last = lastop;
1151
1152         if (lastop) {
1153             lastop->op_lastsib = 1;
1154 #ifdef PERL_OP_PARENT
1155             lastop->op_sibling = parent;
1156 #endif
1157         }
1158     }
1159     return last_del ? first : NULL;
1160 }
1161
1162 /*
1163 =for apidoc op_parent
1164
1165 returns the parent OP of o, if it has a parent.  Returns NULL otherwise.
1166 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
1167 work.
1168
1169 =cut
1170 */
1171
1172 OP *
1173 Perl_op_parent(OP *o)
1174 {
1175     PERL_ARGS_ASSERT_OP_PARENT;
1176 #ifdef PERL_OP_PARENT
1177     while (OP_HAS_SIBLING(o))
1178         o = OP_SIBLING(o);
1179     return o->op_sibling;
1180 #else
1181     PERL_UNUSED_ARG(o);
1182     return NULL;
1183 #endif
1184 }
1185
1186
1187 /* replace the sibling following start with a new UNOP, which becomes
1188  * the parent of the original sibling; e.g.
1189  *
1190  *  op_sibling_newUNOP(P, A, unop-args...)
1191  *
1192  *  P              P
1193  *  |      becomes |
1194  *  A-B-C          A-U-C
1195  *                   |
1196  *                   B
1197  *
1198  * where U is the new UNOP.
1199  *
1200  * parent and start args are the same as for op_sibling_splice();
1201  * type and flags args are as newUNOP().
1202  *
1203  * Returns the new UNOP.
1204  */
1205
1206 OP *
1207 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1208 {
1209     OP *kid, *newop;
1210
1211     kid = op_sibling_splice(parent, start, 1, NULL);
1212     newop = newUNOP(type, flags, kid);
1213     op_sibling_splice(parent, start, 0, newop);
1214     return newop;
1215 }
1216
1217
1218 /* lowest-level newLOGOP-style function - just allocates and populates
1219  * the struct. Higher-level stuff should be done by S_new_logop() /
1220  * newLOGOP(). This function exists mainly to avoid op_first assignment
1221  * being spread throughout this file.
1222  */
1223
1224 LOGOP *
1225 S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1226 {
1227     LOGOP *logop;
1228     OP *kid = first;
1229     NewOp(1101, logop, 1, LOGOP);
1230     logop->op_type = (OPCODE)type;
1231     logop->op_first = first;
1232     logop->op_other = other;
1233     logop->op_flags = OPf_KIDS;
1234     while (kid && OP_HAS_SIBLING(kid))
1235         kid = OP_SIBLING(kid);
1236     if (kid) {
1237         kid->op_lastsib = 1;
1238 #ifdef PERL_OP_PARENT
1239         kid->op_sibling = (OP*)logop;
1240 #endif
1241     }
1242     return logop;
1243 }
1244
1245
1246 /* Contextualizers */
1247
1248 /*
1249 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1250
1251 Applies a syntactic context to an op tree representing an expression.
1252 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1253 or C<G_VOID> to specify the context to apply.  The modified op tree
1254 is returned.
1255
1256 =cut
1257 */
1258
1259 OP *
1260 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1261 {
1262     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1263     switch (context) {
1264         case G_SCALAR: return scalar(o);
1265         case G_ARRAY:  return list(o);
1266         case G_VOID:   return scalarvoid(o);
1267         default:
1268             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1269                        (long) context);
1270     }
1271 }
1272
1273 /*
1274
1275 =for apidoc Am|OP*|op_linklist|OP *o
1276 This function is the implementation of the L</LINKLIST> macro.  It should
1277 not be called directly.
1278
1279 =cut
1280 */
1281
1282 OP *
1283 Perl_op_linklist(pTHX_ OP *o)
1284 {
1285     OP *first;
1286
1287     PERL_ARGS_ASSERT_OP_LINKLIST;
1288
1289     if (o->op_next)
1290         return o->op_next;
1291
1292     /* establish postfix order */
1293     first = cUNOPo->op_first;
1294     if (first) {
1295         OP *kid;
1296         o->op_next = LINKLIST(first);
1297         kid = first;
1298         for (;;) {
1299             OP *sibl = OP_SIBLING(kid);
1300             if (sibl) {
1301                 kid->op_next = LINKLIST(sibl);
1302                 kid = sibl;
1303             } else {
1304                 kid->op_next = o;
1305                 break;
1306             }
1307         }
1308     }
1309     else
1310         o->op_next = o;
1311
1312     return o->op_next;
1313 }
1314
1315 static OP *
1316 S_scalarkids(pTHX_ OP *o)
1317 {
1318     if (o && o->op_flags & OPf_KIDS) {
1319         OP *kid;
1320         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1321             scalar(kid);
1322     }
1323     return o;
1324 }
1325
1326 STATIC OP *
1327 S_scalarboolean(pTHX_ OP *o)
1328 {
1329     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1330
1331     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1332      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1333         if (ckWARN(WARN_SYNTAX)) {
1334             const line_t oldline = CopLINE(PL_curcop);
1335
1336             if (PL_parser && PL_parser->copline != NOLINE) {
1337                 /* This ensures that warnings are reported at the first line
1338                    of the conditional, not the last.  */
1339                 CopLINE_set(PL_curcop, PL_parser->copline);
1340             }
1341             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1342             CopLINE_set(PL_curcop, oldline);
1343         }
1344     }
1345     return scalar(o);
1346 }
1347
1348 static SV *
1349 S_op_varname(pTHX_ const OP *o)
1350 {
1351     assert(o);
1352     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1353            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1354     {
1355         const char funny  = o->op_type == OP_PADAV
1356                          || o->op_type == OP_RV2AV ? '@' : '%';
1357         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1358             GV *gv;
1359             if (cUNOPo->op_first->op_type != OP_GV
1360              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1361                 return NULL;
1362             return varname(gv, funny, 0, NULL, 0, 1);
1363         }
1364         return
1365             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1366     }
1367 }
1368
1369 static void
1370 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1371 { /* or not so pretty :-) */
1372     if (o->op_type == OP_CONST) {
1373         *retsv = cSVOPo_sv;
1374         if (SvPOK(*retsv)) {
1375             SV *sv = *retsv;
1376             *retsv = sv_newmortal();
1377             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1378                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1379         }
1380         else if (!SvOK(*retsv))
1381             *retpv = "undef";
1382     }
1383     else *retpv = "...";
1384 }
1385
1386 static void
1387 S_scalar_slice_warning(pTHX_ const OP *o)
1388 {
1389     OP *kid;
1390     const char lbrack =
1391         o->op_type == OP_HSLICE ? '{' : '[';
1392     const char rbrack =
1393         o->op_type == OP_HSLICE ? '}' : ']';
1394     SV *name;
1395     SV *keysv = NULL; /* just to silence compiler warnings */
1396     const char *key = NULL;
1397
1398     if (!(o->op_private & OPpSLICEWARNING))
1399         return;
1400     if (PL_parser && PL_parser->error_count)
1401         /* This warning can be nonsensical when there is a syntax error. */
1402         return;
1403
1404     kid = cLISTOPo->op_first;
1405     kid = OP_SIBLING(kid); /* get past pushmark */
1406     /* weed out false positives: any ops that can return lists */
1407     switch (kid->op_type) {
1408     case OP_BACKTICK:
1409     case OP_GLOB:
1410     case OP_READLINE:
1411     case OP_MATCH:
1412     case OP_RV2AV:
1413     case OP_EACH:
1414     case OP_VALUES:
1415     case OP_KEYS:
1416     case OP_SPLIT:
1417     case OP_LIST:
1418     case OP_SORT:
1419     case OP_REVERSE:
1420     case OP_ENTERSUB:
1421     case OP_CALLER:
1422     case OP_LSTAT:
1423     case OP_STAT:
1424     case OP_READDIR:
1425     case OP_SYSTEM:
1426     case OP_TMS:
1427     case OP_LOCALTIME:
1428     case OP_GMTIME:
1429     case OP_ENTEREVAL:
1430     case OP_REACH:
1431     case OP_RKEYS:
1432     case OP_RVALUES:
1433         return;
1434     }
1435
1436     /* Don't warn if we have a nulled list either. */
1437     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1438         return;
1439
1440     assert(OP_SIBLING(kid));
1441     name = S_op_varname(aTHX_ OP_SIBLING(kid));
1442     if (!name) /* XS module fiddling with the op tree */
1443         return;
1444     S_op_pretty(aTHX_ kid, &keysv, &key);
1445     assert(SvPOK(name));
1446     sv_chop(name,SvPVX(name)+1);
1447     if (key)
1448        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1449         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1450                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1451                    "%c%s%c",
1452                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1453                     lbrack, key, rbrack);
1454     else
1455        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1456         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1457                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1458                     SVf"%c%"SVf"%c",
1459                     SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1460                     SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1461 }
1462
1463 OP *
1464 Perl_scalar(pTHX_ OP *o)
1465 {
1466     OP *kid;
1467
1468     /* assumes no premature commitment */
1469     if (!o || (PL_parser && PL_parser->error_count)
1470          || (o->op_flags & OPf_WANT)
1471          || o->op_type == OP_RETURN)
1472     {
1473         return o;
1474     }
1475
1476     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1477
1478     switch (o->op_type) {
1479     case OP_REPEAT:
1480         scalar(cBINOPo->op_first);
1481         break;
1482     case OP_OR:
1483     case OP_AND:
1484     case OP_COND_EXPR:
1485         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1486             scalar(kid);
1487         break;
1488         /* FALLTHROUGH */
1489     case OP_SPLIT:
1490     case OP_MATCH:
1491     case OP_QR:
1492     case OP_SUBST:
1493     case OP_NULL:
1494     default:
1495         if (o->op_flags & OPf_KIDS) {
1496             for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1497                 scalar(kid);
1498         }
1499         break;
1500     case OP_LEAVE:
1501     case OP_LEAVETRY:
1502         kid = cLISTOPo->op_first;
1503         scalar(kid);
1504         kid = OP_SIBLING(kid);
1505     do_kids:
1506         while (kid) {
1507             OP *sib = OP_SIBLING(kid);
1508             if (sib && kid->op_type != OP_LEAVEWHEN)
1509                 scalarvoid(kid);
1510             else
1511                 scalar(kid);
1512             kid = sib;
1513         }
1514         PL_curcop = &PL_compiling;
1515         break;
1516     case OP_SCOPE:
1517     case OP_LINESEQ:
1518     case OP_LIST:
1519         kid = cLISTOPo->op_first;
1520         goto do_kids;
1521     case OP_SORT:
1522         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1523         break;
1524     case OP_KVHSLICE:
1525     case OP_KVASLICE:
1526     {
1527         /* Warn about scalar context */
1528         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1529         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1530         SV *name;
1531         SV *keysv;
1532         const char *key = NULL;
1533
1534         /* This warning can be nonsensical when there is a syntax error. */
1535         if (PL_parser && PL_parser->error_count)
1536             break;
1537
1538         if (!ckWARN(WARN_SYNTAX)) break;
1539
1540         kid = cLISTOPo->op_first;
1541         kid = OP_SIBLING(kid); /* get past pushmark */
1542         assert(OP_SIBLING(kid));
1543         name = S_op_varname(aTHX_ OP_SIBLING(kid));
1544         if (!name) /* XS module fiddling with the op tree */
1545             break;
1546         S_op_pretty(aTHX_ kid, &keysv, &key);
1547         assert(SvPOK(name));
1548         sv_chop(name,SvPVX(name)+1);
1549         if (key)
1550   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1551             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1552                        "%%%"SVf"%c%s%c in scalar context better written "
1553                        "as $%"SVf"%c%s%c",
1554                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1555                         lbrack, key, rbrack);
1556         else
1557   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1558             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1559                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1560                        "written as $%"SVf"%c%"SVf"%c",
1561                         SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1562                         SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1563     }
1564     }
1565     return o;
1566 }
1567
1568 OP *
1569 Perl_scalarvoid(pTHX_ OP *o)
1570 {
1571     dVAR;
1572     OP *kid;
1573     SV *useless_sv = NULL;
1574     const char* useless = NULL;
1575     SV* sv;
1576     U8 want;
1577
1578     PERL_ARGS_ASSERT_SCALARVOID;
1579
1580     if (o->op_type == OP_NEXTSTATE
1581         || o->op_type == OP_DBSTATE
1582         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1583                                       || o->op_targ == OP_DBSTATE)))
1584         PL_curcop = (COP*)o;            /* for warning below */
1585
1586     /* assumes no premature commitment */
1587     want = o->op_flags & OPf_WANT;
1588     if ((want && want != OPf_WANT_SCALAR)
1589          || (PL_parser && PL_parser->error_count)
1590          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1591     {
1592         return o;
1593     }
1594
1595     if ((o->op_private & OPpTARGET_MY)
1596         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1597     {
1598         return scalar(o);                       /* As if inside SASSIGN */
1599     }
1600
1601     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1602
1603     switch (o->op_type) {
1604     default:
1605         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1606             break;
1607         /* FALLTHROUGH */
1608     case OP_REPEAT:
1609         if (o->op_flags & OPf_STACKED)
1610             break;
1611         goto func_ops;
1612     case OP_SUBSTR:
1613         if (o->op_private == 4)
1614             break;
1615         /* FALLTHROUGH */
1616     case OP_GVSV:
1617     case OP_WANTARRAY:
1618     case OP_GV:
1619     case OP_SMARTMATCH:
1620     case OP_PADSV:
1621     case OP_PADAV:
1622     case OP_PADHV:
1623     case OP_PADANY:
1624     case OP_AV2ARYLEN:
1625     case OP_REF:
1626     case OP_REFGEN:
1627     case OP_SREFGEN:
1628     case OP_DEFINED:
1629     case OP_HEX:
1630     case OP_OCT:
1631     case OP_LENGTH:
1632     case OP_VEC:
1633     case OP_INDEX:
1634     case OP_RINDEX:
1635     case OP_SPRINTF:
1636     case OP_AELEM:
1637     case OP_AELEMFAST:
1638     case OP_AELEMFAST_LEX:
1639     case OP_ASLICE:
1640     case OP_KVASLICE:
1641     case OP_HELEM:
1642     case OP_HSLICE:
1643     case OP_KVHSLICE:
1644     case OP_UNPACK:
1645     case OP_PACK:
1646     case OP_JOIN:
1647     case OP_LSLICE:
1648     case OP_ANONLIST:
1649     case OP_ANONHASH:
1650     case OP_SORT:
1651     case OP_REVERSE:
1652     case OP_RANGE:
1653     case OP_FLIP:
1654     case OP_FLOP:
1655     case OP_CALLER:
1656     case OP_FILENO:
1657     case OP_EOF:
1658     case OP_TELL:
1659     case OP_GETSOCKNAME:
1660     case OP_GETPEERNAME:
1661     case OP_READLINK:
1662     case OP_TELLDIR:
1663     case OP_GETPPID:
1664     case OP_GETPGRP:
1665     case OP_GETPRIORITY:
1666     case OP_TIME:
1667     case OP_TMS:
1668     case OP_LOCALTIME:
1669     case OP_GMTIME:
1670     case OP_GHBYNAME:
1671     case OP_GHBYADDR:
1672     case OP_GHOSTENT:
1673     case OP_GNBYNAME:
1674     case OP_GNBYADDR:
1675     case OP_GNETENT:
1676     case OP_GPBYNAME:
1677     case OP_GPBYNUMBER:
1678     case OP_GPROTOENT:
1679     case OP_GSBYNAME:
1680     case OP_GSBYPORT:
1681     case OP_GSERVENT:
1682     case OP_GPWNAM:
1683     case OP_GPWUID:
1684     case OP_GGRNAM:
1685     case OP_GGRGID:
1686     case OP_GETLOGIN:
1687     case OP_PROTOTYPE:
1688     case OP_RUNCV:
1689       func_ops:
1690         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1691             /* Otherwise it's "Useless use of grep iterator" */
1692             useless = OP_DESC(o);
1693         break;
1694
1695     case OP_SPLIT:
1696         kid = cLISTOPo->op_first;
1697         if (kid && kid->op_type == OP_PUSHRE
1698                 && !kid->op_targ
1699                 && !(o->op_flags & OPf_STACKED)
1700 #ifdef USE_ITHREADS
1701                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1702 #else
1703                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1704 #endif
1705             useless = OP_DESC(o);
1706         break;
1707
1708     case OP_NOT:
1709        kid = cUNOPo->op_first;
1710        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1711            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1712                 goto func_ops;
1713        }
1714        useless = "negative pattern binding (!~)";
1715        break;
1716
1717     case OP_SUBST:
1718         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1719             useless = "non-destructive substitution (s///r)";
1720         break;
1721
1722     case OP_TRANSR:
1723         useless = "non-destructive transliteration (tr///r)";
1724         break;
1725
1726     case OP_RV2GV:
1727     case OP_RV2SV:
1728     case OP_RV2AV:
1729     case OP_RV2HV:
1730         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1731                 (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
1732             useless = "a variable";
1733         break;
1734
1735     case OP_CONST:
1736         sv = cSVOPo_sv;
1737         if (cSVOPo->op_private & OPpCONST_STRICT)
1738             no_bareword_allowed(o);
1739         else {
1740             if (ckWARN(WARN_VOID)) {
1741                 NV nv;
1742                 /* don't warn on optimised away booleans, eg 
1743                  * use constant Foo, 5; Foo || print; */
1744                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1745                     useless = NULL;
1746                 /* the constants 0 and 1 are permitted as they are
1747                    conventionally used as dummies in constructs like
1748                         1 while some_condition_with_side_effects;  */
1749                 else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
1750                     useless = NULL;
1751                 else if (SvPOK(sv)) {
1752                     SV * const dsv = newSVpvs("");
1753                     useless_sv
1754                         = Perl_newSVpvf(aTHX_
1755                                         "a constant (%s)",
1756                                         pv_pretty(dsv, SvPVX_const(sv),
1757                                                   SvCUR(sv), 32, NULL, NULL,
1758                                                   PERL_PV_PRETTY_DUMP
1759                                                   | PERL_PV_ESCAPE_NOCLEAR
1760                                                   | PERL_PV_ESCAPE_UNI_DETECT));
1761                     SvREFCNT_dec_NN(dsv);
1762                 }
1763                 else if (SvOK(sv)) {
1764                     useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
1765                 }
1766                 else
1767                     useless = "a constant (undef)";
1768             }
1769         }
1770         op_null(o);             /* don't execute or even remember it */
1771         break;
1772
1773     case OP_POSTINC:
1774         o->op_type = OP_PREINC;         /* pre-increment is faster */
1775         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1776         break;
1777
1778     case OP_POSTDEC:
1779         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1780         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1781         break;
1782
1783     case OP_I_POSTINC:
1784         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1785         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1786         break;
1787
1788     case OP_I_POSTDEC:
1789         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1790         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1791         break;
1792
1793     case OP_SASSIGN: {
1794         OP *rv2gv;
1795         UNOP *refgen, *rv2cv;
1796         LISTOP *exlist;
1797
1798         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1799             break;
1800
1801         rv2gv = ((BINOP *)o)->op_last;
1802         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1803             break;
1804
1805         refgen = (UNOP *)((BINOP *)o)->op_first;
1806
1807         if (!refgen || (refgen->op_type != OP_REFGEN
1808                         && refgen->op_type != OP_SREFGEN))
1809             break;
1810
1811         exlist = (LISTOP *)refgen->op_first;
1812         if (!exlist || exlist->op_type != OP_NULL
1813             || exlist->op_targ != OP_LIST)
1814             break;
1815
1816         if (exlist->op_first->op_type != OP_PUSHMARK
1817          && exlist->op_first != exlist->op_last)
1818             break;
1819
1820         rv2cv = (UNOP*)exlist->op_last;
1821
1822         if (rv2cv->op_type != OP_RV2CV)
1823             break;
1824
1825         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1826         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1827         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1828
1829         o->op_private |= OPpASSIGN_CV_TO_GV;
1830         rv2gv->op_private |= OPpDONT_INIT_GV;
1831         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1832
1833         break;
1834     }
1835
1836     case OP_AASSIGN: {
1837         inplace_aassign(o);
1838         break;
1839     }
1840
1841     case OP_OR:
1842     case OP_AND:
1843         kid = cLOGOPo->op_first;
1844         if (kid->op_type == OP_NOT
1845             && (kid->op_flags & OPf_KIDS)) {
1846             if (o->op_type == OP_AND) {
1847                 o->op_type = OP_OR;
1848                 o->op_ppaddr = PL_ppaddr[OP_OR];
1849             } else {
1850                 o->op_type = OP_AND;
1851                 o->op_ppaddr = PL_ppaddr[OP_AND];
1852             }
1853             op_null(kid);
1854         }
1855         /* FALLTHROUGH */
1856
1857     case OP_DOR:
1858     case OP_COND_EXPR:
1859     case OP_ENTERGIVEN:
1860     case OP_ENTERWHEN:
1861         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1862             scalarvoid(kid);
1863         break;
1864
1865     case OP_NULL:
1866         if (o->op_flags & OPf_STACKED)
1867             break;
1868         /* FALLTHROUGH */
1869     case OP_NEXTSTATE:
1870     case OP_DBSTATE:
1871     case OP_ENTERTRY:
1872     case OP_ENTER:
1873         if (!(o->op_flags & OPf_KIDS))
1874             break;
1875         /* FALLTHROUGH */
1876     case OP_SCOPE:
1877     case OP_LEAVE:
1878     case OP_LEAVETRY:
1879     case OP_LEAVELOOP:
1880     case OP_LINESEQ:
1881     case OP_LEAVEGIVEN:
1882     case OP_LEAVEWHEN:
1883       kids:
1884         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1885             scalarvoid(kid);
1886         break;
1887     case OP_LIST:
1888         /* If the first kid after pushmark is something that the padrange
1889            optimisation would reject, then null the list and the pushmark.
1890          */
1891         if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
1892          && (  !(kid = OP_SIBLING(kid))
1893             || (  kid->op_type != OP_PADSV
1894                && kid->op_type != OP_PADAV
1895                && kid->op_type != OP_PADHV)
1896             || kid->op_private & ~OPpLVAL_INTRO
1897             || !(kid = OP_SIBLING(kid))
1898             || (  kid->op_type != OP_PADSV
1899                && kid->op_type != OP_PADAV
1900                && kid->op_type != OP_PADHV)
1901             || kid->op_private & ~OPpLVAL_INTRO)
1902         ) {
1903             op_null(cUNOPo->op_first); /* NULL the pushmark */
1904             op_null(o); /* NULL the list */
1905         }
1906         goto kids;
1907     case OP_ENTEREVAL:
1908         scalarkids(o);
1909         break;
1910     case OP_SCALAR:
1911         return scalar(o);
1912     }
1913
1914     if (useless_sv) {
1915         /* mortalise it, in case warnings are fatal.  */
1916         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1917                        "Useless use of %"SVf" in void context",
1918                        SVfARG(sv_2mortal(useless_sv)));
1919     }
1920     else if (useless) {
1921        Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1922                       "Useless use of %s in void context",
1923                       useless);
1924     }
1925     return o;
1926 }
1927
1928 static OP *
1929 S_listkids(pTHX_ OP *o)
1930 {
1931     if (o && o->op_flags & OPf_KIDS) {
1932         OP *kid;
1933         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1934             list(kid);
1935     }
1936     return o;
1937 }
1938
1939 OP *
1940 Perl_list(pTHX_ OP *o)
1941 {
1942     OP *kid;
1943
1944     /* assumes no premature commitment */
1945     if (!o || (o->op_flags & OPf_WANT)
1946          || (PL_parser && PL_parser->error_count)
1947          || o->op_type == OP_RETURN)
1948     {
1949         return o;
1950     }
1951
1952     if ((o->op_private & OPpTARGET_MY)
1953         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1954     {
1955         return o;                               /* As if inside SASSIGN */
1956     }
1957
1958     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1959
1960     switch (o->op_type) {
1961     case OP_FLOP:
1962     case OP_REPEAT:
1963         list(cBINOPo->op_first);
1964         break;
1965     case OP_OR:
1966     case OP_AND:
1967     case OP_COND_EXPR:
1968         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1969             list(kid);
1970         break;
1971     default:
1972     case OP_MATCH:
1973     case OP_QR:
1974     case OP_SUBST:
1975     case OP_NULL:
1976         if (!(o->op_flags & OPf_KIDS))
1977             break;
1978         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1979             list(cBINOPo->op_first);
1980             return gen_constant_list(o);
1981         }
1982         listkids(o);
1983         break;
1984     case OP_LIST:
1985         listkids(o);
1986         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
1987             op_null(cUNOPo->op_first); /* NULL the pushmark */
1988             op_null(o); /* NULL the list */
1989         }
1990         break;
1991     case OP_LEAVE:
1992     case OP_LEAVETRY:
1993         kid = cLISTOPo->op_first;
1994         list(kid);
1995         kid = OP_SIBLING(kid);
1996     do_kids:
1997         while (kid) {
1998             OP *sib = OP_SIBLING(kid);
1999             if (sib && kid->op_type != OP_LEAVEWHEN)
2000                 scalarvoid(kid);
2001             else
2002                 list(kid);
2003             kid = sib;
2004         }
2005         PL_curcop = &PL_compiling;
2006         break;
2007     case OP_SCOPE:
2008     case OP_LINESEQ:
2009         kid = cLISTOPo->op_first;
2010         goto do_kids;
2011     }
2012     return o;
2013 }
2014
2015 static OP *
2016 S_scalarseq(pTHX_ OP *o)
2017 {
2018     if (o) {
2019         const OPCODE type = o->op_type;
2020
2021         if (type == OP_LINESEQ || type == OP_SCOPE ||
2022             type == OP_LEAVE || type == OP_LEAVETRY)
2023         {
2024             OP *kid;
2025             for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2026                 if (OP_HAS_SIBLING(kid)) {
2027                     scalarvoid(kid);
2028                 }
2029             }
2030             PL_curcop = &PL_compiling;
2031         }
2032         o->op_flags &= ~OPf_PARENS;
2033         if (PL_hints & HINT_BLOCK_SCOPE)
2034             o->op_flags |= OPf_PARENS;
2035     }
2036     else
2037         o = newOP(OP_STUB, 0);
2038     return o;
2039 }
2040
2041 STATIC OP *
2042 S_modkids(pTHX_ OP *o, I32 type)
2043 {
2044     if (o && o->op_flags & OPf_KIDS) {
2045         OP *kid;
2046         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2047             op_lvalue(kid, type);
2048     }
2049     return o;
2050 }
2051
2052 /*
2053 =for apidoc finalize_optree
2054
2055 This function finalizes the optree.  Should be called directly after
2056 the complete optree is built.  It does some additional
2057 checking which can't be done in the normal ck_xxx functions and makes
2058 the tree thread-safe.
2059
2060 =cut
2061 */
2062 void
2063 Perl_finalize_optree(pTHX_ OP* o)
2064 {
2065     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2066
2067     ENTER;
2068     SAVEVPTR(PL_curcop);
2069
2070     finalize_op(o);
2071
2072     LEAVE;
2073 }
2074
2075 #ifdef USE_ITHREADS
2076 /* Relocate sv to the pad for thread safety.
2077  * Despite being a "constant", the SV is written to,
2078  * for reference counts, sv_upgrade() etc. */
2079 PERL_STATIC_INLINE void
2080 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2081 {
2082     PADOFFSET ix;
2083     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2084     if (!*svp) return;
2085     ix = pad_alloc(OP_CONST, SVf_READONLY);
2086     SvREFCNT_dec(PAD_SVl(ix));
2087     PAD_SETSV(ix, *svp);
2088     /* XXX I don't know how this isn't readonly already. */
2089     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2090     *svp = NULL;
2091     *targp = ix;
2092 }
2093 #endif
2094
2095
2096 STATIC void
2097 S_finalize_op(pTHX_ OP* o)
2098 {
2099     PERL_ARGS_ASSERT_FINALIZE_OP;
2100
2101
2102     switch (o->op_type) {
2103     case OP_NEXTSTATE:
2104     case OP_DBSTATE:
2105         PL_curcop = ((COP*)o);          /* for warnings */
2106         break;
2107     case OP_EXEC:
2108         if (OP_HAS_SIBLING(o)) {
2109             OP *sib = OP_SIBLING(o);
2110             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2111                 && ckWARN(WARN_EXEC)
2112                 && OP_HAS_SIBLING(sib))
2113             {
2114                     const OPCODE type = OP_SIBLING(sib)->op_type;
2115                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2116                         const line_t oldline = CopLINE(PL_curcop);
2117                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2118                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2119                             "Statement unlikely to be reached");
2120                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2121                             "\t(Maybe you meant system() when you said exec()?)\n");
2122                         CopLINE_set(PL_curcop, oldline);
2123                     }
2124             }
2125         }
2126         break;
2127
2128     case OP_GV:
2129         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2130             GV * const gv = cGVOPo_gv;
2131             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2132                 /* XXX could check prototype here instead of just carping */
2133                 SV * const sv = sv_newmortal();
2134                 gv_efullname3(sv, gv, NULL);
2135                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2136                     "%"SVf"() called too early to check prototype",
2137                     SVfARG(sv));
2138             }
2139         }
2140         break;
2141
2142     case OP_CONST:
2143         if (cSVOPo->op_private & OPpCONST_STRICT)
2144             no_bareword_allowed(o);
2145         /* FALLTHROUGH */
2146 #ifdef USE_ITHREADS
2147     case OP_HINTSEVAL:
2148         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2149 #endif
2150         break;
2151
2152 #ifdef USE_ITHREADS
2153     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2154     case OP_METHOD_NAMED:
2155         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2156         break;
2157 #endif
2158
2159     case OP_HELEM: {
2160         UNOP *rop;
2161         SV *lexname;
2162         GV **fields;
2163         SVOP *key_op;
2164         OP *kid;
2165         bool check_fields;
2166
2167         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2168             break;
2169
2170         rop = (UNOP*)((BINOP*)o)->op_first;
2171
2172         goto check_keys;
2173
2174     case OP_HSLICE:
2175         S_scalar_slice_warning(aTHX_ o);
2176         /* FALLTHROUGH */
2177
2178     case OP_KVHSLICE:
2179         kid = OP_SIBLING(cLISTOPo->op_first);
2180         if (/* I bet there's always a pushmark... */
2181             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2182             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2183         {
2184             break;
2185         }
2186
2187         key_op = (SVOP*)(kid->op_type == OP_CONST
2188                                 ? kid
2189                                 : OP_SIBLING(kLISTOP->op_first));
2190
2191         rop = (UNOP*)((LISTOP*)o)->op_last;
2192
2193       check_keys:       
2194         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2195             rop = NULL;
2196         else if (rop->op_first->op_type == OP_PADSV)
2197             /* @$hash{qw(keys here)} */
2198             rop = (UNOP*)rop->op_first;
2199         else {
2200             /* @{$hash}{qw(keys here)} */
2201             if (rop->op_first->op_type == OP_SCOPE
2202                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2203                 {
2204                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2205                 }
2206             else
2207                 rop = NULL;
2208         }
2209
2210         lexname = NULL; /* just to silence compiler warnings */
2211         fields  = NULL; /* just to silence compiler warnings */
2212
2213         check_fields =
2214             rop
2215          && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2216              SvPAD_TYPED(lexname))
2217          && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2218          && isGV(*fields) && GvHV(*fields);
2219         for (; key_op;
2220              key_op = (SVOP*)OP_SIBLING(key_op)) {
2221             SV **svp, *sv;
2222             if (key_op->op_type != OP_CONST)
2223                 continue;
2224             svp = cSVOPx_svp(key_op);
2225
2226             /* Make the CONST have a shared SV */
2227             if ((!SvIsCOW_shared_hash(sv = *svp))
2228              && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2229                 SSize_t keylen;
2230                 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2231                 SV *nsv = newSVpvn_share(key,
2232                                          SvUTF8(sv) ? -keylen : keylen, 0);
2233                 SvREFCNT_dec_NN(sv);
2234                 *svp = nsv;
2235             }
2236
2237             if (check_fields
2238              && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2239                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" " 
2240                            "in variable %"SVf" of type %"HEKf, 
2241                       SVfARG(*svp), SVfARG(lexname),
2242                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2243             }
2244         }
2245         break;
2246     }
2247     case OP_ASLICE:
2248         S_scalar_slice_warning(aTHX_ o);
2249         break;
2250
2251     case OP_SUBST: {
2252         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2253             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2254         break;
2255     }
2256     default:
2257         break;
2258     }
2259
2260     if (o->op_flags & OPf_KIDS) {
2261         OP *kid;
2262
2263 #ifdef DEBUGGING
2264         /* check that op_last points to the last sibling, and that
2265          * the last op_sibling field points back to the parent, and
2266          * that the only ops with KIDS are those which are entitled to
2267          * them */
2268         U32 type = o->op_type;
2269         U32 family;
2270         bool has_last;
2271
2272         if (type == OP_NULL) {
2273             type = o->op_targ;
2274             /* ck_glob creates a null UNOP with ex-type GLOB
2275              * (which is a list op. So pretend it wasn't a listop */
2276             if (type == OP_GLOB)
2277                 type = OP_NULL;
2278         }
2279         family = PL_opargs[type] & OA_CLASS_MASK;
2280
2281         has_last = (   family == OA_BINOP
2282                     || family == OA_LISTOP
2283                     || family == OA_PMOP
2284                     || family == OA_LOOP
2285                    );
2286         assert(  has_last /* has op_first and op_last, or ...
2287               ... has (or may have) op_first: */
2288               || family == OA_UNOP
2289               || family == OA_LOGOP
2290               || family == OA_BASEOP_OR_UNOP
2291               || family == OA_FILESTATOP
2292               || family == OA_LOOPEXOP
2293               || family == OA_METHOP
2294               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2295               || type == OP_SASSIGN
2296               || type == OP_CUSTOM
2297               || type == OP_NULL /* new_logop does this */
2298               );
2299         /* XXX list form of 'x' is has a null op_last. This is wrong,
2300          * but requires too much hacking (e.g. in Deparse) to fix for
2301          * now */
2302         if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2303             assert(has_last);
2304             has_last = 0;
2305         }
2306
2307         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2308 #  ifdef PERL_OP_PARENT
2309             if (!OP_HAS_SIBLING(kid)) {
2310                 if (has_last)
2311                     assert(kid == cLISTOPo->op_last);
2312                 assert(kid->op_sibling == o);
2313             }
2314 #  else
2315             if (OP_HAS_SIBLING(kid)) {
2316                 assert(!kid->op_lastsib);
2317             }
2318             else {
2319                 assert(kid->op_lastsib);
2320                 if (has_last)
2321                     assert(kid == cLISTOPo->op_last);
2322             }
2323 #  endif
2324         }
2325 #endif
2326
2327         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2328             finalize_op(kid);
2329     }
2330 }
2331
2332 /*
2333 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2334
2335 Propagate lvalue ("modifiable") context to an op and its children.
2336 I<type> represents the context type, roughly based on the type of op that
2337 would do the modifying, although C<local()> is represented by OP_NULL,
2338 because it has no op type of its own (it is signalled by a flag on
2339 the lvalue op).
2340
2341 This function detects things that can't be modified, such as C<$x+1>, and
2342 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2343 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2344
2345 It also flags things that need to behave specially in an lvalue context,
2346 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2347
2348 =cut
2349 */
2350
2351 static bool
2352 S_vivifies(const OPCODE type)
2353 {
2354     switch(type) {
2355     case OP_RV2AV:     case   OP_ASLICE:
2356     case OP_RV2HV:     case OP_KVASLICE:
2357     case OP_RV2SV:     case   OP_HSLICE:
2358     case OP_AELEMFAST: case OP_KVHSLICE:
2359     case OP_HELEM:
2360     case OP_AELEM:
2361         return 1;
2362     }
2363     return 0;
2364 }
2365
2366 static void
2367 S_lvref(pTHX_ OP *o, I32 type)
2368 {
2369     dVAR;
2370     OP *kid;
2371     switch (o->op_type) {
2372     case OP_COND_EXPR:
2373         for (kid = OP_SIBLING(cUNOPo->op_first); kid;
2374              kid = OP_SIBLING(kid))
2375             S_lvref(aTHX_ kid, type);
2376         /* FALLTHROUGH */
2377     case OP_PUSHMARK:
2378         return;
2379     case OP_RV2AV:
2380         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2381         o->op_flags |= OPf_STACKED;
2382         if (o->op_flags & OPf_PARENS) {
2383             if (o->op_private & OPpLVAL_INTRO) {
2384                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2385                       "localized parenthesized array in list assignment"));
2386                 return;
2387             }
2388           slurpy:
2389             o->op_type = OP_LVAVREF;
2390             o->op_ppaddr = PL_ppaddr[OP_LVAVREF];
2391             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2392             o->op_flags |= OPf_MOD|OPf_REF;
2393             return;
2394         }
2395         o->op_private |= OPpLVREF_AV;
2396         goto checkgv;
2397     case OP_RV2CV:
2398         kid = cUNOPo->op_first;
2399         if (kid->op_type == OP_NULL)
2400             kid = cUNOPx(kUNOP->op_first->op_sibling)
2401                 ->op_first;
2402         o->op_private = OPpLVREF_CV;
2403         if (kid->op_type == OP_GV)
2404             o->op_flags |= OPf_STACKED;
2405         else if (kid->op_type == OP_PADCV) {
2406             o->op_targ = kid->op_targ;
2407             kid->op_targ = 0;
2408             op_free(cUNOPo->op_first);
2409             cUNOPo->op_first = NULL;
2410             o->op_flags &=~ OPf_KIDS;
2411         }
2412         else goto badref;
2413         break;
2414     case OP_RV2HV:
2415         if (o->op_flags & OPf_PARENS) {
2416           parenhash:
2417             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2418                                  "parenthesized hash in list assignment"));
2419                 return;
2420         }
2421         o->op_private |= OPpLVREF_HV;
2422         /* FALLTHROUGH */
2423     case OP_RV2SV:
2424       checkgv:
2425         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2426         o->op_flags |= OPf_STACKED;
2427         break;
2428     case OP_PADHV:
2429         if (o->op_flags & OPf_PARENS) goto parenhash;
2430         o->op_private |= OPpLVREF_HV;
2431         /* FALLTHROUGH */
2432     case OP_PADSV:
2433         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2434         break;
2435     case OP_PADAV:
2436         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2437         if (o->op_flags & OPf_PARENS) goto slurpy;
2438         o->op_private |= OPpLVREF_AV;
2439         break;
2440     case OP_AELEM:
2441     case OP_HELEM:
2442         o->op_private |= OPpLVREF_ELEM;
2443         o->op_flags   |= OPf_STACKED;
2444         break;
2445     case OP_ASLICE:
2446     case OP_HSLICE:
2447         o->op_type = OP_LVREFSLICE;
2448         o->op_ppaddr = PL_ppaddr[OP_LVREFSLICE];
2449         o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2450         return;
2451     case OP_NULL:
2452         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2453             goto badref;
2454         else if (!(o->op_flags & OPf_KIDS))
2455             return;
2456         if (o->op_targ != OP_LIST) {
2457             S_lvref(aTHX_ cBINOPo->op_first, type);
2458             return;
2459         }
2460         /* FALLTHROUGH */
2461     case OP_LIST:
2462         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2463             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2464             S_lvref(aTHX_ kid, type);
2465         }
2466         return;
2467     case OP_STUB:
2468         if (o->op_flags & OPf_PARENS)
2469             return;
2470         /* FALLTHROUGH */
2471     default:
2472       badref:
2473         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2474         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2475                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2476                       ? "do block"
2477                       : OP_DESC(o),
2478                      PL_op_desc[type]));
2479         return;
2480     }
2481     o->op_type = OP_LVREF;
2482     o->op_ppaddr = PL_ppaddr[OP_LVREF];
2483     o->op_private &=
2484         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2485     if (type == OP_ENTERLOOP)
2486         o->op_private |= OPpLVREF_ITER;
2487 }
2488
2489 OP *
2490 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2491 {
2492     dVAR;
2493     OP *kid;
2494     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2495     int localize = -1;
2496
2497     if (!o || (PL_parser && PL_parser->error_count))
2498         return o;
2499
2500     if ((o->op_private & OPpTARGET_MY)
2501         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2502     {
2503         return o;
2504     }
2505
2506     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2507
2508     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2509
2510     switch (o->op_type) {
2511     case OP_UNDEF:
2512         PL_modcount++;
2513         return o;
2514     case OP_STUB:
2515         if ((o->op_flags & OPf_PARENS))
2516             break;
2517         goto nomod;
2518     case OP_ENTERSUB:
2519         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2520             !(o->op_flags & OPf_STACKED)) {
2521             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
2522             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2523             assert(cUNOPo->op_first->op_type == OP_NULL);
2524             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2525             break;
2526         }
2527         else {                          /* lvalue subroutine call */
2528             o->op_private |= OPpLVAL_INTRO;
2529             PL_modcount = RETURN_UNLIMITED_NUMBER;
2530             if (type == OP_GREPSTART || type == OP_ENTERSUB
2531              || type == OP_REFGEN    || type == OP_LEAVESUBLV) {
2532                 /* Potential lvalue context: */
2533                 o->op_private |= OPpENTERSUB_INARGS;
2534                 break;
2535             }
2536             else {                      /* Compile-time error message: */
2537                 OP *kid = cUNOPo->op_first;
2538                 CV *cv;
2539                 GV *gv;
2540
2541                 if (kid->op_type != OP_PUSHMARK) {
2542                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2543                         Perl_croak(aTHX_
2544                                 "panic: unexpected lvalue entersub "
2545                                 "args: type/targ %ld:%"UVuf,
2546                                 (long)kid->op_type, (UV)kid->op_targ);
2547                     kid = kLISTOP->op_first;
2548                 }
2549                 while (OP_HAS_SIBLING(kid))
2550                     kid = OP_SIBLING(kid);
2551                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2552                     break;      /* Postpone until runtime */
2553                 }
2554
2555                 kid = kUNOP->op_first;
2556                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2557                     kid = kUNOP->op_first;
2558                 if (kid->op_type == OP_NULL)
2559                     Perl_croak(aTHX_
2560                                "Unexpected constant lvalue entersub "
2561                                "entry via type/targ %ld:%"UVuf,
2562                                (long)kid->op_type, (UV)kid->op_targ);
2563                 if (kid->op_type != OP_GV) {
2564                     break;
2565                 }
2566
2567                 gv = kGVOP_gv;
2568                 cv = isGV(gv)
2569                     ? GvCV(gv)
2570                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2571                         ? MUTABLE_CV(SvRV(gv))
2572                         : NULL;
2573                 if (!cv)
2574                     break;
2575                 if (CvLVALUE(cv))
2576                     break;
2577             }
2578         }
2579         /* FALLTHROUGH */
2580     default:
2581       nomod:
2582         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2583         /* grep, foreach, subcalls, refgen */
2584         if (type == OP_GREPSTART || type == OP_ENTERSUB
2585          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2586             break;
2587         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2588                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2589                       ? "do block"
2590                       : (o->op_type == OP_ENTERSUB
2591                         ? "non-lvalue subroutine call"
2592                         : OP_DESC(o))),
2593                      type ? PL_op_desc[type] : "local"));
2594         return o;
2595
2596     case OP_PREINC:
2597     case OP_PREDEC:
2598     case OP_POW:
2599     case OP_MULTIPLY:
2600     case OP_DIVIDE:
2601     case OP_MODULO:
2602     case OP_REPEAT:
2603     case OP_ADD:
2604     case OP_SUBTRACT:
2605     case OP_CONCAT:
2606     case OP_LEFT_SHIFT:
2607     case OP_RIGHT_SHIFT:
2608     case OP_BIT_AND:
2609     case OP_BIT_XOR:
2610     case OP_BIT_OR:
2611     case OP_I_MULTIPLY:
2612     case OP_I_DIVIDE:
2613     case OP_I_MODULO:
2614     case OP_I_ADD:
2615     case OP_I_SUBTRACT:
2616         if (!(o->op_flags & OPf_STACKED))
2617             goto nomod;
2618         PL_modcount++;
2619         break;
2620
2621     case OP_COND_EXPR:
2622         localize = 1;
2623         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2624             op_lvalue(kid, type);
2625         break;
2626
2627     case OP_RV2AV:
2628     case OP_RV2HV:
2629         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2630            PL_modcount = RETURN_UNLIMITED_NUMBER;
2631             return o;           /* Treat \(@foo) like ordinary list. */
2632         }
2633         /* FALLTHROUGH */
2634     case OP_RV2GV:
2635         if (scalar_mod_type(o, type))
2636             goto nomod;
2637         ref(cUNOPo->op_first, o->op_type);
2638         /* FALLTHROUGH */
2639     case OP_ASLICE:
2640     case OP_HSLICE:
2641         localize = 1;
2642         /* FALLTHROUGH */
2643     case OP_AASSIGN:
2644         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2645         if (type == OP_LEAVESUBLV && (
2646                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2647              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2648            ))
2649             o->op_private |= OPpMAYBE_LVSUB;
2650         /* FALLTHROUGH */
2651     case OP_NEXTSTATE:
2652     case OP_DBSTATE:
2653        PL_modcount = RETURN_UNLIMITED_NUMBER;
2654         break;
2655     case OP_KVHSLICE:
2656     case OP_KVASLICE:
2657         if (type == OP_LEAVESUBLV)
2658             o->op_private |= OPpMAYBE_LVSUB;
2659         goto nomod;
2660     case OP_AV2ARYLEN:
2661         PL_hints |= HINT_BLOCK_SCOPE;
2662         if (type == OP_LEAVESUBLV)
2663             o->op_private |= OPpMAYBE_LVSUB;
2664         PL_modcount++;
2665         break;
2666     case OP_RV2SV:
2667         ref(cUNOPo->op_first, o->op_type);
2668         localize = 1;
2669         /* FALLTHROUGH */
2670     case OP_GV:
2671         PL_hints |= HINT_BLOCK_SCOPE;
2672         /* FALLTHROUGH */
2673     case OP_SASSIGN:
2674     case OP_ANDASSIGN:
2675     case OP_ORASSIGN:
2676     case OP_DORASSIGN:
2677         PL_modcount++;
2678         break;
2679
2680     case OP_AELEMFAST:
2681     case OP_AELEMFAST_LEX:
2682         localize = -1;
2683         PL_modcount++;
2684         break;
2685
2686     case OP_PADAV:
2687     case OP_PADHV:
2688        PL_modcount = RETURN_UNLIMITED_NUMBER;
2689         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2690             return o;           /* Treat \(@foo) like ordinary list. */
2691         if (scalar_mod_type(o, type))
2692             goto nomod;
2693         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2694           && type == OP_LEAVESUBLV)
2695             o->op_private |= OPpMAYBE_LVSUB;
2696         /* FALLTHROUGH */
2697     case OP_PADSV:
2698         PL_modcount++;
2699         if (!type) /* local() */
2700             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2701                  PAD_COMPNAME_SV(o->op_targ));
2702         break;
2703
2704     case OP_PUSHMARK:
2705         localize = 0;
2706         break;
2707
2708     case OP_KEYS:
2709     case OP_RKEYS:
2710         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2711             goto nomod;
2712         goto lvalue_func;
2713     case OP_SUBSTR:
2714         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2715             goto nomod;
2716         /* FALLTHROUGH */
2717     case OP_POS:
2718     case OP_VEC:
2719       lvalue_func:
2720         if (type == OP_LEAVESUBLV)
2721             o->op_private |= OPpMAYBE_LVSUB;
2722         if (o->op_flags & OPf_KIDS)
2723             op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2724         break;
2725
2726     case OP_AELEM:
2727     case OP_HELEM:
2728         ref(cBINOPo->op_first, o->op_type);
2729         if (type == OP_ENTERSUB &&
2730              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2731             o->op_private |= OPpLVAL_DEFER;
2732         if (type == OP_LEAVESUBLV)
2733             o->op_private |= OPpMAYBE_LVSUB;
2734         localize = 1;
2735         PL_modcount++;
2736         break;
2737
2738     case OP_LEAVE:
2739     case OP_LEAVELOOP:
2740         o->op_private |= OPpLVALUE;
2741         /* FALLTHROUGH */
2742     case OP_SCOPE:
2743     case OP_ENTER:
2744     case OP_LINESEQ:
2745         localize = 0;
2746         if (o->op_flags & OPf_KIDS)
2747             op_lvalue(cLISTOPo->op_last, type);
2748         break;
2749
2750     case OP_NULL:
2751         localize = 0;
2752         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2753             goto nomod;
2754         else if (!(o->op_flags & OPf_KIDS))
2755             break;
2756         if (o->op_targ != OP_LIST) {
2757             op_lvalue(cBINOPo->op_first, type);
2758             break;
2759         }
2760         /* FALLTHROUGH */
2761     case OP_LIST:
2762         localize = 0;
2763         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2764             /* elements might be in void context because the list is
2765                in scalar context or because they are attribute sub calls */
2766             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2767                 op_lvalue(kid, type);
2768         break;
2769
2770     case OP_COREARGS:
2771         return o;
2772
2773     case OP_AND:
2774     case OP_OR:
2775         if (type == OP_LEAVESUBLV
2776          || !S_vivifies(cLOGOPo->op_first->op_type))
2777             op_lvalue(cLOGOPo->op_first, type);
2778         if (type == OP_LEAVESUBLV
2779          || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2780             op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2781         goto nomod;
2782
2783     case OP_SREFGEN:
2784         if (type != OP_AASSIGN && type != OP_SASSIGN
2785          && type != OP_ENTERLOOP)
2786             goto nomod;
2787         /* Don’t bother applying lvalue context to the ex-list.  */
2788         kid = cUNOPx(cUNOPo->op_first)->op_first;
2789         assert (!OP_HAS_SIBLING(kid));
2790         goto kid_2lvref;
2791     case OP_REFGEN:
2792         if (type != OP_AASSIGN) goto nomod;
2793         kid = cUNOPo->op_first;
2794       kid_2lvref:
2795         {
2796             const U8 ec = PL_parser ? PL_parser->error_count : 0;
2797             S_lvref(aTHX_ kid, type);
2798             if (!PL_parser || PL_parser->error_count == ec) {
2799                 if (!FEATURE_REFALIASING_IS_ENABLED)
2800                     Perl_croak(aTHX_
2801                        "Experimental aliasing via reference not enabled");
2802                 Perl_ck_warner_d(aTHX_
2803                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
2804                                 "Aliasing via reference is experimental");
2805             }
2806         }
2807         if (o->op_type == OP_REFGEN)
2808             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
2809         op_null(o);
2810         return o;
2811     }
2812
2813     /* [20011101.069] File test operators interpret OPf_REF to mean that
2814        their argument is a filehandle; thus \stat(".") should not set
2815        it. AMS 20011102 */
2816     if (type == OP_REFGEN &&
2817         PL_check[o->op_type] == Perl_ck_ftst)
2818         return o;
2819
2820     if (type != OP_LEAVESUBLV)
2821         o->op_flags |= OPf_MOD;
2822
2823     if (type == OP_AASSIGN || type == OP_SASSIGN)
2824         o->op_flags |= OPf_SPECIAL|OPf_REF;
2825     else if (!type) { /* local() */
2826         switch (localize) {
2827         case 1:
2828             o->op_private |= OPpLVAL_INTRO;
2829             o->op_flags &= ~OPf_SPECIAL;
2830             PL_hints |= HINT_BLOCK_SCOPE;
2831             break;
2832         case 0:
2833             break;
2834         case -1:
2835             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2836                            "Useless localization of %s", OP_DESC(o));
2837         }
2838     }
2839     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2840              && type != OP_LEAVESUBLV)
2841         o->op_flags |= OPf_REF;
2842     return o;
2843 }
2844
2845 STATIC bool
2846 S_scalar_mod_type(const OP *o, I32 type)
2847 {
2848     switch (type) {
2849     case OP_POS:
2850     case OP_SASSIGN:
2851         if (o && o->op_type == OP_RV2GV)
2852             return FALSE;
2853         /* FALLTHROUGH */
2854     case OP_PREINC:
2855     case OP_PREDEC:
2856     case OP_POSTINC:
2857     case OP_POSTDEC:
2858     case OP_I_PREINC:
2859     case OP_I_PREDEC:
2860     case OP_I_POSTINC:
2861     case OP_I_POSTDEC:
2862     case OP_POW:
2863     case OP_MULTIPLY:
2864     case OP_DIVIDE:
2865     case OP_MODULO:
2866     case OP_REPEAT:
2867     case OP_ADD:
2868     case OP_SUBTRACT:
2869     case OP_I_MULTIPLY:
2870     case OP_I_DIVIDE:
2871     case OP_I_MODULO:
2872     case OP_I_ADD:
2873     case OP_I_SUBTRACT:
2874     case OP_LEFT_SHIFT:
2875     case OP_RIGHT_SHIFT:
2876     case OP_BIT_AND:
2877     case OP_BIT_XOR:
2878     case OP_BIT_OR:
2879     case OP_CONCAT:
2880     case OP_SUBST:
2881     case OP_TRANS:
2882     case OP_TRANSR:
2883     case OP_READ:
2884     case OP_SYSREAD:
2885     case OP_RECV:
2886     case OP_ANDASSIGN:
2887     case OP_ORASSIGN:
2888     case OP_DORASSIGN:
2889         return TRUE;
2890     default:
2891         return FALSE;
2892     }
2893 }
2894
2895 STATIC bool
2896 S_is_handle_constructor(const OP *o, I32 numargs)
2897 {
2898     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2899
2900     switch (o->op_type) {
2901     case OP_PIPE_OP:
2902     case OP_SOCKPAIR:
2903         if (numargs == 2)
2904             return TRUE;
2905         /* FALLTHROUGH */
2906     case OP_SYSOPEN:
2907     case OP_OPEN:
2908     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2909     case OP_SOCKET:
2910     case OP_OPEN_DIR:
2911     case OP_ACCEPT:
2912         if (numargs == 1)
2913             return TRUE;
2914         /* FALLTHROUGH */
2915     default:
2916         return FALSE;
2917     }
2918 }
2919
2920 static OP *
2921 S_refkids(pTHX_ OP *o, I32 type)
2922 {
2923     if (o && o->op_flags & OPf_KIDS) {
2924         OP *kid;
2925         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2926             ref(kid, type);
2927     }
2928     return o;
2929 }
2930
2931 OP *
2932 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2933 {
2934     dVAR;
2935     OP *kid;
2936
2937     PERL_ARGS_ASSERT_DOREF;
2938
2939     if (!o || (PL_parser && PL_parser->error_count))
2940         return o;
2941
2942     switch (o->op_type) {
2943     case OP_ENTERSUB:
2944         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2945             !(o->op_flags & OPf_STACKED)) {
2946             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2947             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2948             assert(cUNOPo->op_first->op_type == OP_NULL);
2949             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2950             o->op_flags |= OPf_SPECIAL;
2951         }
2952         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2953             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2954                               : type == OP_RV2HV ? OPpDEREF_HV
2955                               : OPpDEREF_SV);
2956             o->op_flags |= OPf_MOD;
2957         }
2958
2959         break;
2960
2961     case OP_COND_EXPR:
2962         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2963             doref(kid, type, set_op_ref);
2964         break;
2965     case OP_RV2SV:
2966         if (type == OP_DEFINED)
2967             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2968         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2969         /* FALLTHROUGH */
2970     case OP_PADSV:
2971         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2972             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2973                               : type == OP_RV2HV ? OPpDEREF_HV
2974                               : OPpDEREF_SV);
2975             o->op_flags |= OPf_MOD;
2976         }
2977         break;
2978
2979     case OP_RV2AV:
2980     case OP_RV2HV:
2981         if (set_op_ref)
2982             o->op_flags |= OPf_REF;
2983         /* FALLTHROUGH */
2984     case OP_RV2GV:
2985         if (type == OP_DEFINED)
2986             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2987         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2988         break;
2989
2990     case OP_PADAV:
2991     case OP_PADHV:
2992         if (set_op_ref)
2993             o->op_flags |= OPf_REF;
2994         break;
2995
2996     case OP_SCALAR:
2997     case OP_NULL:
2998         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2999             break;
3000         doref(cBINOPo->op_first, type, set_op_ref);
3001         break;
3002     case OP_AELEM:
3003     case OP_HELEM:
3004         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3005         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3006             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3007                               : type == OP_RV2HV ? OPpDEREF_HV
3008                               : OPpDEREF_SV);
3009             o->op_flags |= OPf_MOD;
3010         }
3011         break;
3012
3013     case OP_SCOPE:
3014     case OP_LEAVE:
3015         set_op_ref = FALSE;
3016         /* FALLTHROUGH */
3017     case OP_ENTER:
3018     case OP_LIST:
3019         if (!(o->op_flags & OPf_KIDS))
3020             break;
3021         doref(cLISTOPo->op_last, type, set_op_ref);
3022         break;
3023     default:
3024         break;
3025     }
3026     return scalar(o);
3027
3028 }
3029
3030 STATIC OP *
3031 S_dup_attrlist(pTHX_ OP *o)
3032 {
3033     OP *rop;
3034
3035     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3036
3037     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3038      * where the first kid is OP_PUSHMARK and the remaining ones
3039      * are OP_CONST.  We need to push the OP_CONST values.
3040      */
3041     if (o->op_type == OP_CONST)
3042         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3043     else {
3044         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3045         rop = NULL;
3046         for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
3047             if (o->op_type == OP_CONST)
3048                 rop = op_append_elem(OP_LIST, rop,
3049                                   newSVOP(OP_CONST, o->op_flags,
3050                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3051         }
3052     }
3053     return rop;
3054 }
3055
3056 STATIC void
3057 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3058 {
3059     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3060
3061     PERL_ARGS_ASSERT_APPLY_ATTRS;
3062
3063     /* fake up C<use attributes $pkg,$rv,@attrs> */
3064
3065 #define ATTRSMODULE "attributes"
3066 #define ATTRSMODULE_PM "attributes.pm"
3067
3068     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3069                          newSVpvs(ATTRSMODULE),
3070                          NULL,
3071                          op_prepend_elem(OP_LIST,
3072                                       newSVOP(OP_CONST, 0, stashsv),
3073                                       op_prepend_elem(OP_LIST,
3074                                                    newSVOP(OP_CONST, 0,
3075                                                            newRV(target)),
3076                                                    dup_attrlist(attrs))));
3077 }
3078
3079 STATIC void
3080 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3081 {
3082     OP *pack, *imop, *arg;
3083     SV *meth, *stashsv, **svp;
3084
3085     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3086
3087     if (!attrs)
3088         return;
3089
3090     assert(target->op_type == OP_PADSV ||
3091            target->op_type == OP_PADHV ||
3092            target->op_type == OP_PADAV);
3093
3094     /* Ensure that attributes.pm is loaded. */
3095     /* Don't force the C<use> if we don't need it. */
3096     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3097     if (svp && *svp != &PL_sv_undef)
3098         NOOP;   /* already in %INC */
3099     else
3100         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3101                                newSVpvs(ATTRSMODULE), NULL);
3102
3103     /* Need package name for method call. */
3104     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3105
3106     /* Build up the real arg-list. */
3107     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3108
3109     arg = newOP(OP_PADSV, 0);
3110     arg->op_targ = target->op_targ;
3111     arg = op_prepend_elem(OP_LIST,
3112                        newSVOP(OP_CONST, 0, stashsv),
3113                        op_prepend_elem(OP_LIST,
3114                                     newUNOP(OP_REFGEN, 0,
3115                                             op_lvalue(arg, OP_REFGEN)),
3116                                     dup_attrlist(attrs)));
3117
3118     /* Fake up a method call to import */
3119     meth = newSVpvs_share("import");
3120     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3121                    op_append_elem(OP_LIST,
3122                                op_prepend_elem(OP_LIST, pack, arg),
3123                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3124
3125     /* Combine the ops. */
3126     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3127 }
3128
3129 /*
3130 =notfor apidoc apply_attrs_string
3131
3132 Attempts to apply a list of attributes specified by the C<attrstr> and
3133 C<len> arguments to the subroutine identified by the C<cv> argument which
3134 is expected to be associated with the package identified by the C<stashpv>
3135 argument (see L<attributes>).  It gets this wrong, though, in that it
3136 does not correctly identify the boundaries of the individual attribute
3137 specifications within C<attrstr>.  This is not really intended for the
3138 public API, but has to be listed here for systems such as AIX which
3139 need an explicit export list for symbols.  (It's called from XS code
3140 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3141 to respect attribute syntax properly would be welcome.
3142
3143 =cut
3144 */
3145
3146 void
3147 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3148                         const char *attrstr, STRLEN len)
3149 {
3150     OP *attrs = NULL;
3151
3152     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3153
3154     if (!len) {
3155         len = strlen(attrstr);
3156     }
3157
3158     while (len) {
3159         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3160         if (len) {
3161             const char * const sstr = attrstr;
3162             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3163             attrs = op_append_elem(OP_LIST, attrs,
3164                                 newSVOP(OP_CONST, 0,
3165                                         newSVpvn(sstr, attrstr-sstr)));
3166         }
3167     }
3168
3169     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3170                      newSVpvs(ATTRSMODULE),
3171                      NULL, op_prepend_elem(OP_LIST,
3172                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3173                                   op_prepend_elem(OP_LIST,
3174                                                newSVOP(OP_CONST, 0,
3175                                                        newRV(MUTABLE_SV(cv))),
3176                                                attrs)));
3177 }
3178
3179 STATIC void
3180 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3181 {
3182     OP *new_proto = NULL;
3183     STRLEN pvlen;
3184     char *pv;
3185     OP *o;
3186
3187     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3188
3189     if (!*attrs)
3190         return;
3191
3192     o = *attrs;
3193     if (o->op_type == OP_CONST) {
3194         pv = SvPV(cSVOPo_sv, pvlen);
3195         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3196             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3197             SV ** const tmpo = cSVOPx_svp(o);
3198             SvREFCNT_dec(cSVOPo_sv);
3199             *tmpo = tmpsv;
3200             new_proto = o;
3201             *attrs = NULL;
3202         }
3203     } else if (o->op_type == OP_LIST) {
3204         OP * lasto;
3205         assert(o->op_flags & OPf_KIDS);
3206         lasto = cLISTOPo->op_first;
3207         assert(lasto->op_type == OP_PUSHMARK);
3208         for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3209             if (o->op_type == OP_CONST) {
3210                 pv = SvPV(cSVOPo_sv, pvlen);
3211                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3212                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3213                     SV ** const tmpo = cSVOPx_svp(o);
3214                     SvREFCNT_dec(cSVOPo_sv);
3215                     *tmpo = tmpsv;
3216                     if (new_proto && ckWARN(WARN_MISC)) {
3217                         STRLEN new_len;
3218                         const char * newp = SvPV(cSVOPo_sv, new_len);
3219                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3220                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3221                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3222                         op_free(new_proto);
3223                     }
3224                     else if (new_proto)
3225                         op_free(new_proto);
3226                     new_proto = o;
3227                     /* excise new_proto from the list */
3228                     op_sibling_splice(*attrs, lasto, 1, NULL);
3229                     o = lasto;
3230                     continue;
3231                 }
3232             }
3233             lasto = o;
3234         }
3235         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3236            would get pulled in with no real need */
3237         if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3238             op_free(*attrs);
3239             *attrs = NULL;
3240         }
3241     }
3242
3243     if (new_proto) {
3244         SV *svname;
3245         if (isGV(name)) {
3246             svname = sv_newmortal();
3247             gv_efullname3(svname, name, NULL);
3248         }
3249         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3250             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3251         else
3252             svname = (SV *)name;
3253         if (ckWARN(WARN_ILLEGALPROTO))
3254             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3255         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3256             STRLEN old_len, new_len;
3257             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3258             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3259
3260             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3261                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3262                 " in %"SVf,
3263                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3264                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3265                 SVfARG(svname));
3266         }
3267         if (*proto)
3268             op_free(*proto);
3269         *proto = new_proto;
3270     }
3271 }
3272
3273 static void
3274 S_cant_declare(pTHX_ OP *o)
3275 {
3276     if (o->op_type == OP_NULL
3277      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3278         o = cUNOPo->op_first;
3279     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3280                              o->op_type == OP_NULL
3281                                && o->op_flags & OPf_SPECIAL
3282                                  ? "do block"
3283                                  : OP_DESC(o),
3284                              PL_parser->in_my == KEY_our   ? "our"   :
3285                              PL_parser->in_my == KEY_state ? "state" :
3286                                                              "my"));
3287 }
3288
3289 STATIC OP *
3290 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3291 {
3292     I32 type;
3293     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3294
3295     PERL_ARGS_ASSERT_MY_KID;
3296
3297     if (!o || (PL_parser && PL_parser->error_count))
3298         return o;
3299
3300     type = o->op_type;
3301
3302     if (type == OP_LIST) {
3303         OP *kid;
3304         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3305             my_kid(kid, attrs, imopsp);
3306         return o;
3307     } else if (type == OP_UNDEF || type == OP_STUB) {
3308         return o;
3309     } else if (type == OP_RV2SV ||      /* "our" declaration */
3310                type == OP_RV2AV ||
3311                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3312         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3313             S_cant_declare(aTHX_ o);
3314         } else if (attrs) {
3315             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3316             assert(PL_parser);
3317             PL_parser->in_my = FALSE;
3318             PL_parser->in_my_stash = NULL;
3319             apply_attrs(GvSTASH(gv),
3320                         (type == OP_RV2SV ? GvSV(gv) :
3321                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3322                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3323                         attrs);
3324         }
3325         o->op_private |= OPpOUR_INTRO;
3326         return o;
3327     }
3328     else if (type != OP_PADSV &&
3329              type != OP_PADAV &&
3330              type != OP_PADHV &&
3331              type != OP_PUSHMARK)
3332     {
3333         S_cant_declare(aTHX_ o);
3334         return o;
3335     }
3336     else if (attrs && type != OP_PUSHMARK) {
3337         HV *stash;
3338
3339         assert(PL_parser);
3340         PL_parser->in_my = FALSE;
3341         PL_parser->in_my_stash = NULL;
3342
3343         /* check for C<my Dog $spot> when deciding package */
3344         stash = PAD_COMPNAME_TYPE(o->op_targ);
3345         if (!stash)
3346             stash = PL_curstash;
3347         apply_attrs_my(stash, o, attrs, imopsp);
3348     }
3349     o->op_flags |= OPf_MOD;
3350     o->op_private |= OPpLVAL_INTRO;
3351     if (stately)
3352         o->op_private |= OPpPAD_STATE;
3353     return o;
3354 }
3355
3356 OP *
3357 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3358 {
3359     OP *rops;
3360     int maybe_scalar = 0;
3361
3362     PERL_ARGS_ASSERT_MY_ATTRS;
3363
3364 /* [perl #17376]: this appears to be premature, and results in code such as
3365    C< our(%x); > executing in list mode rather than void mode */
3366 #if 0
3367     if (o->op_flags & OPf_PARENS)
3368         list(o);
3369     else
3370         maybe_scalar = 1;
3371 #else
3372     maybe_scalar = 1;
3373 #endif
3374     if (attrs)
3375         SAVEFREEOP(attrs);
3376     rops = NULL;
3377     o = my_kid(o, attrs, &rops);
3378     if (rops) {
3379         if (maybe_scalar && o->op_type == OP_PADSV) {
3380             o = scalar(op_append_list(OP_LIST, rops, o));
3381             o->op_private |= OPpLVAL_INTRO;
3382         }
3383         else {
3384             /* The listop in rops might have a pushmark at the beginning,
3385                which will mess up list assignment. */
3386             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3387             if (rops->op_type == OP_LIST && 
3388                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3389             {
3390                 OP * const pushmark = lrops->op_first;
3391                 /* excise pushmark */
3392                 op_sibling_splice(rops, NULL, 1, NULL);
3393                 op_free(pushmark);
3394             }
3395             o = op_append_list(OP_LIST, o, rops);
3396         }
3397     }
3398     PL_parser->in_my = FALSE;
3399     PL_parser->in_my_stash = NULL;
3400     return o;
3401 }
3402
3403 OP *
3404 Perl_sawparens(pTHX_ OP *o)
3405 {
3406     PERL_UNUSED_CONTEXT;
3407     if (o)
3408         o->op_flags |= OPf_PARENS;
3409     return o;
3410 }
3411
3412 OP *
3413 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3414 {
3415     OP *o;
3416     bool ismatchop = 0;
3417     const OPCODE ltype = left->op_type;
3418     const OPCODE rtype = right->op_type;
3419
3420     PERL_ARGS_ASSERT_BIND_MATCH;
3421
3422     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3423           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3424     {
3425       const char * const desc
3426           = PL_op_desc[(
3427                           rtype == OP_SUBST || rtype == OP_TRANS
3428                        || rtype == OP_TRANSR
3429                        )
3430                        ? (int)rtype : OP_MATCH];
3431       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3432       SV * const name =
3433         S_op_varname(aTHX_ left);
3434       if (name)
3435         Perl_warner(aTHX_ packWARN(WARN_MISC),
3436              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3437              desc, SVfARG(name), SVfARG(name));
3438       else {
3439         const char * const sample = (isary
3440              ? "@array" : "%hash");
3441         Perl_warner(aTHX_ packWARN(WARN_MISC),
3442              "Applying %s to %s will act on scalar(%s)",
3443              desc, sample, sample);
3444       }
3445     }
3446
3447     if (rtype == OP_CONST &&
3448         cSVOPx(right)->op_private & OPpCONST_BARE &&
3449         cSVOPx(right)->op_private & OPpCONST_STRICT)
3450     {
3451         no_bareword_allowed(right);
3452     }
3453
3454     /* !~ doesn't make sense with /r, so error on it for now */
3455     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3456         type == OP_NOT)
3457         /* diag_listed_as: Using !~ with %s doesn't make sense */
3458         yyerror("Using !~ with s///r doesn't make sense");
3459     if (rtype == OP_TRANSR && type == OP_NOT)
3460         /* diag_listed_as: Using !~ with %s doesn't make sense */
3461         yyerror("Using !~ with tr///r doesn't make sense");
3462
3463     ismatchop = (rtype == OP_MATCH ||
3464                  rtype == OP_SUBST ||
3465                  rtype == OP_TRANS || rtype == OP_TRANSR)
3466              && !(right->op_flags & OPf_SPECIAL);
3467     if (ismatchop && right->op_private & OPpTARGET_MY) {
3468         right->op_targ = 0;
3469         right->op_private &= ~OPpTARGET_MY;
3470     }
3471     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3472         OP *newleft;
3473
3474         right->op_flags |= OPf_STACKED;
3475         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3476             ! (rtype == OP_TRANS &&
3477                right->op_private & OPpTRANS_IDENTICAL) &&
3478             ! (rtype == OP_SUBST &&
3479                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3480             newleft = op_lvalue(left, rtype);
3481         else
3482             newleft = left;
3483         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3484             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3485         else
3486             o = op_prepend_elem(rtype, scalar(newleft), right);
3487         if (type == OP_NOT)
3488             return newUNOP(OP_NOT, 0, scalar(o));
3489         return o;
3490     }
3491     else
3492         return bind_match(type, left,
3493                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3494 }
3495
3496 OP *
3497 Perl_invert(pTHX_ OP *o)
3498 {
3499     if (!o)
3500         return NULL;
3501     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3502 }
3503
3504 /*
3505 =for apidoc Amx|OP *|op_scope|OP *o
3506
3507 Wraps up an op tree with some additional ops so that at runtime a dynamic
3508 scope will be created.  The original ops run in the new dynamic scope,
3509 and then, provided that they exit normally, the scope will be unwound.
3510 The additional ops used to create and unwind the dynamic scope will
3511 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3512 instead if the ops are simple enough to not need the full dynamic scope
3513 structure.
3514
3515 =cut
3516 */
3517
3518 OP *
3519 Perl_op_scope(pTHX_ OP *o)
3520 {
3521     dVAR;
3522     if (o) {
3523         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3524             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3525             o->op_type = OP_LEAVE;
3526             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3527         }
3528         else if (o->op_type == OP_LINESEQ) {
3529             OP *kid;
3530             o->op_type = OP_SCOPE;
3531             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3532             kid = ((LISTOP*)o)->op_first;
3533             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3534                 op_null(kid);
3535
3536                 /* The following deals with things like 'do {1 for 1}' */
3537                 kid = OP_SIBLING(kid);
3538                 if (kid &&
3539                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3540                     op_null(kid);
3541             }
3542         }
3543         else
3544             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3545     }
3546     return o;
3547 }
3548
3549 OP *
3550 Perl_op_unscope(pTHX_ OP *o)
3551 {
3552     if (o && o->op_type == OP_LINESEQ) {
3553         OP *kid = cLISTOPo->op_first;
3554         for(; kid; kid = OP_SIBLING(kid))
3555             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3556                 op_null(kid);
3557     }
3558     return o;
3559 }
3560
3561 int
3562 Perl_block_start(pTHX_ int full)
3563 {
3564     const int retval = PL_savestack_ix;
3565
3566     pad_block_start(full);
3567     SAVEHINTS();
3568     PL_hints &= ~HINT_BLOCK_SCOPE;
3569     SAVECOMPILEWARNINGS();
3570     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3571
3572     CALL_BLOCK_HOOKS(bhk_start, full);
3573
3574     return retval;
3575 }
3576
3577 OP*
3578 Perl_block_end(pTHX_ I32 floor, OP *seq)
3579 {
3580     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3581     OP* retval = scalarseq(seq);
3582     OP *o;
3583
3584     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3585
3586     LEAVE_SCOPE(floor);
3587     if (needblockscope)
3588         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3589     o = pad_leavemy();
3590
3591     if (o) {
3592         /* pad_leavemy has created a sequence of introcv ops for all my
3593            subs declared in the block.  We have to replicate that list with
3594            clonecv ops, to deal with this situation:
3595
3596                sub {
3597                    my sub s1;
3598                    my sub s2;
3599                    sub s1 { state sub foo { \&s2 } }
3600                }->()
3601
3602            Originally, I was going to have introcv clone the CV and turn
3603            off the stale flag.  Since &s1 is declared before &s2, the
3604            introcv op for &s1 is executed (on sub entry) before the one for
3605            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3606            cloned, since it is a state sub) closes over &s2 and expects
3607            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3608            then &s2 is still marked stale.  Since &s1 is not active, and
3609            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3610            ble will not stay shared’ warning.  Because it is the same stub
3611            that will be used when the introcv op for &s2 is executed, clos-
3612            ing over it is safe.  Hence, we have to turn off the stale flag
3613            on all lexical subs in the block before we clone any of them.
3614            Hence, having introcv clone the sub cannot work.  So we create a
3615            list of ops like this:
3616
3617                lineseq
3618                   |
3619                   +-- introcv
3620                   |
3621                   +-- introcv
3622                   |
3623                   +-- introcv
3624                   |
3625                   .
3626                   .
3627                   .
3628                   |
3629                   +-- clonecv
3630                   |
3631                   +-- clonecv
3632                   |
3633                   +-- clonecv
3634                   |
3635                   .
3636                   .
3637                   .
3638          */
3639         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3640         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3641         for (;; kid = OP_SIBLING(kid)) {
3642             OP *newkid = newOP(OP_CLONECV, 0);
3643             newkid->op_targ = kid->op_targ;
3644             o = op_append_elem(OP_LINESEQ, o, newkid);
3645             if (kid == last) break;
3646         }
3647         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3648     }
3649
3650     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3651
3652     return retval;
3653 }
3654
3655 /*
3656 =head1 Compile-time scope hooks
3657
3658 =for apidoc Aox||blockhook_register
3659
3660 Register a set of hooks to be called when the Perl lexical scope changes
3661 at compile time.  See L<perlguts/"Compile-time scope hooks">.
3662
3663 =cut
3664 */
3665
3666 void
3667 Perl_blockhook_register(pTHX_ BHK *hk)
3668 {
3669     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3670
3671     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3672 }
3673
3674 /*
3675 =for apidoc Am|OP *|newDEFSVOP|
3676
3677 Constructs and returns an op to access C<$_>, either as a lexical
3678 variable (if declared as C<my $_>) in the current scope, or the
3679 global C<$_>.
3680
3681 =cut
3682 */
3683
3684 OP *
3685 Perl_newDEFSVOP(pTHX)
3686 {
3687     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3688     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3689         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3690     }
3691     else {
3692         OP * const o = newOP(OP_PADSV, 0);
3693         o->op_targ = offset;
3694         return o;
3695     }
3696 }
3697
3698 void
3699 Perl_newPROG(pTHX_ OP *o)
3700 {
3701     PERL_ARGS_ASSERT_NEWPROG;
3702
3703     if (PL_in_eval) {
3704         PERL_CONTEXT *cx;
3705         I32 i;
3706         if (PL_eval_root)
3707                 return;
3708         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3709                                ((PL_in_eval & EVAL_KEEPERR)
3710                                 ? OPf_SPECIAL : 0), o);
3711
3712         cx = &cxstack[cxstack_ix];
3713         assert(CxTYPE(cx) == CXt_EVAL);
3714
3715         if ((cx->blk_gimme & G_WANT) == G_VOID)
3716             scalarvoid(PL_eval_root);
3717         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3718             list(PL_eval_root);
3719         else
3720             scalar(PL_eval_root);
3721
3722         PL_eval_start = op_linklist(PL_eval_root);
3723         PL_eval_root->op_private |= OPpREFCOUNTED;
3724         OpREFCNT_set(PL_eval_root, 1);
3725         PL_eval_root->op_next = 0;
3726         i = PL_savestack_ix;
3727         SAVEFREEOP(o);
3728         ENTER;
3729         CALL_PEEP(PL_eval_start);
3730         finalize_optree(PL_eval_root);
3731         S_prune_chain_head(&PL_eval_start);
3732         LEAVE;
3733         PL_savestack_ix = i;
3734     }
3735     else {
3736         if (o->op_type == OP_STUB) {
3737             /* This block is entered if nothing is compiled for the main
3738                program. This will be the case for an genuinely empty main
3739                program, or one which only has BEGIN blocks etc, so already
3740                run and freed.
3741
3742                Historically (5.000) the guard above was !o. However, commit
3743                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3744                c71fccf11fde0068, changed perly.y so that newPROG() is now
3745                called with the output of block_end(), which returns a new
3746                OP_STUB for the case of an empty optree. ByteLoader (and
3747                maybe other things) also take this path, because they set up
3748                PL_main_start and PL_main_root directly, without generating an
3749                optree.
3750
3751                If the parsing the main program aborts (due to parse errors,
3752                or due to BEGIN or similar calling exit), then newPROG()
3753                isn't even called, and hence this code path and its cleanups
3754                are skipped. This shouldn't make a make a difference:
3755                * a non-zero return from perl_parse is a failure, and
3756                  perl_destruct() should be called immediately.
3757                * however, if exit(0) is called during the parse, then
3758                  perl_parse() returns 0, and perl_run() is called. As
3759                  PL_main_start will be NULL, perl_run() will return
3760                  promptly, and the exit code will remain 0.
3761             */
3762
3763             PL_comppad_name = 0;
3764             PL_compcv = 0;
3765             S_op_destroy(aTHX_ o);
3766             return;
3767         }
3768         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3769         PL_curcop = &PL_compiling;
3770         PL_main_start = LINKLIST(PL_main_root);
3771         PL_main_root->op_private |= OPpREFCOUNTED;
3772         OpREFCNT_set(PL_main_root, 1);
3773         PL_main_root->op_next = 0;
3774         CALL_PEEP(PL_main_start);
3775         finalize_optree(PL_main_root);
3776         S_prune_chain_head(&PL_main_start);
3777         cv_forget_slab(PL_compcv);
3778         PL_compcv = 0;
3779
3780         /* Register with debugger */
3781         if (PERLDB_INTER) {
3782             CV * const cv = get_cvs("DB::postponed", 0);
3783             if (cv) {
3784                 dSP;
3785                 PUSHMARK(SP);
3786                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3787                 PUTBACK;
3788                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3789             }
3790         }
3791     }
3792 }
3793
3794 OP *
3795 Perl_localize(pTHX_ OP *o, I32 lex)
3796 {
3797     PERL_ARGS_ASSERT_LOCALIZE;
3798
3799     if (o->op_flags & OPf_PARENS)
3800 /* [perl #17376]: this appears to be premature, and results in code such as
3801    C< our(%x); > executing in list mode rather than void mode */
3802 #if 0
3803         list(o);
3804 #else
3805         NOOP;
3806 #endif
3807     else {
3808         if ( PL_parser->bufptr > PL_parser->oldbufptr
3809             && PL_parser->bufptr[-1] == ','
3810             && ckWARN(WARN_PARENTHESIS))
3811         {
3812             char *s = PL_parser->bufptr;
3813             bool sigil = FALSE;
3814
3815             /* some heuristics to detect a potential error */
3816             while (*s && (strchr(", \t\n", *s)))
3817                 s++;
3818
3819             while (1) {
3820                 if (*s && strchr("@$%*", *s) && *++s
3821                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3822                     s++;
3823                     sigil = TRUE;
3824                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3825                         s++;
3826                     while (*s && (strchr(", \t\n", *s)))
3827                         s++;
3828                 }
3829                 else
3830                     break;
3831             }
3832             if (sigil && (*s == ';' || *s == '=')) {
3833                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3834                                 "Parentheses missing around \"%s\" list",
3835                                 lex
3836                                     ? (PL_parser->in_my == KEY_our
3837                                         ? "our"
3838                                         : PL_parser->in_my == KEY_state
3839                                             ? "state"
3840                                             : "my")
3841                                     : "local");
3842             }
3843         }
3844     }
3845     if (lex)
3846         o = my(o);
3847     else
3848         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3849     PL_parser->in_my = FALSE;
3850     PL_parser->in_my_stash = NULL;
3851     return o;
3852 }
3853
3854 OP *
3855 Perl_jmaybe(pTHX_ OP *o)
3856 {
3857     PERL_ARGS_ASSERT_JMAYBE;
3858
3859     if (o->op_type == OP_LIST) {
3860         OP * const o2
3861             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3862         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3863     }
3864     return o;
3865 }
3866
3867 PERL_STATIC_INLINE OP *
3868 S_op_std_init(pTHX_ OP *o)
3869 {
3870     I32 type = o->op_type;
3871
3872     PERL_ARGS_ASSERT_OP_STD_INIT;
3873
3874     if (PL_opargs[type] & OA_RETSCALAR)
3875         scalar(o);
3876     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3877         o->op_targ = pad_alloc(type, SVs_PADTMP);
3878
3879     return o;
3880 }
3881
3882 PERL_STATIC_INLINE OP *
3883 S_op_integerize(pTHX_ OP *o)
3884 {
3885     I32 type = o->op_type;
3886
3887     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3888
3889     /* integerize op. */
3890     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3891     {
3892         dVAR;
3893         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3894     }
3895
3896     if (type == OP_NEGATE)
3897         /* XXX might want a ck_negate() for this */
3898         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3899
3900     return o;
3901 }
3902
3903 static OP *
3904 S_fold_constants(pTHX_ OP *o)
3905 {
3906     dVAR;
3907     OP * VOL curop;
3908     OP *newop;
3909     VOL I32 type = o->op_type;
3910     bool folded;
3911     SV * VOL sv = NULL;
3912     int ret = 0;
3913     I32 oldscope;
3914     OP *old_next;
3915     SV * const oldwarnhook = PL_warnhook;
3916     SV * const olddiehook  = PL_diehook;
3917     COP not_compiling;
3918     U8 oldwarn = PL_dowarn;
3919     dJMPENV;
3920
3921     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3922
3923     if (!(PL_opargs[type] & OA_FOLDCONST))
3924         goto nope;
3925
3926     switch (type) {
3927     case OP_UCFIRST:
3928     case OP_LCFIRST:
3929     case OP_UC:
3930     case OP_LC:
3931     case OP_FC:
3932 #ifdef USE_LOCALE_CTYPE
3933         if (IN_LC_COMPILETIME(LC_CTYPE))
3934             goto nope;
3935 #endif
3936         break;
3937     case OP_SLT:
3938     case OP_SGT:
3939     case OP_SLE:
3940     case OP_SGE:
3941     case OP_SCMP:
3942 #ifdef USE_LOCALE_COLLATE
3943         if (IN_LC_COMPILETIME(LC_COLLATE))
3944             goto nope;
3945 #endif
3946         break;
3947     case OP_SPRINTF:
3948         /* XXX what about the numeric ops? */
3949 #ifdef USE_LOCALE_NUMERIC
3950         if (IN_LC_COMPILETIME(LC_NUMERIC))
3951             goto nope;
3952 #endif
3953         break;
3954     case OP_PACK:
3955         if (!OP_HAS_SIBLING(cLISTOPo->op_first)
3956           || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
3957             goto nope;
3958         {
3959             SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
3960             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3961             {
3962                 const char *s = SvPVX_const(sv);
3963                 while (s < SvEND(sv)) {
3964                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
3965                     s++;
3966                 }
3967             }
3968         }
3969         break;
3970     case OP_REPEAT:
3971         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3972         break;
3973     case OP_SREFGEN:
3974         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3975          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3976             goto nope;
3977     }
3978
3979     if (PL_parser && PL_parser->error_count)
3980         goto nope;              /* Don't try to run w/ errors */
3981
3982     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3983         const OPCODE type = curop->op_type;
3984         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3985             type != OP_LIST &&
3986             type != OP_SCALAR &&
3987             type != OP_NULL &&
3988             type != OP_PUSHMARK)
3989         {
3990             goto nope;
3991         }
3992     }
3993
3994     curop = LINKLIST(o);
3995     old_next = o->op_next;
3996     o->op_next = 0;
3997     PL_op = curop;
3998
3999     oldscope = PL_scopestack_ix;
4000     create_eval_scope(G_FAKINGEVAL);
4001
4002     /* Verify that we don't need to save it:  */
4003     assert(PL_curcop == &PL_compiling);
4004     StructCopy(&PL_compiling, &not_compiling, COP);
4005     PL_curcop = &not_compiling;
4006     /* The above ensures that we run with all the correct hints of the
4007        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
4008     assert(IN_PERL_RUNTIME);
4009     PL_warnhook = PERL_WARNHOOK_FATAL;
4010     PL_diehook  = NULL;
4011     JMPENV_PUSH(ret);
4012
4013     /* Effective $^W=1.  */
4014     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4015         PL_dowarn |= G_WARN_ON;
4016
4017     switch (ret) {
4018     case 0:
4019         CALLRUNOPS(aTHX);
4020         sv = *(PL_stack_sp--);
4021         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4022             pad_swipe(o->op_targ,  FALSE);
4023         }
4024         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4025             SvREFCNT_inc_simple_void(sv);
4026             SvTEMP_off(sv);
4027         }
4028         else { assert(SvIMMORTAL(sv)); }
4029         break;
4030     case 3:
4031         /* Something tried to die.  Abandon constant folding.  */
4032         /* Pretend the error never happened.  */
4033         CLEAR_ERRSV();
4034         o->op_next = old_next;
4035         break;
4036     default:
4037         JMPENV_POP;
4038         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4039         PL_warnhook = oldwarnhook;
4040         PL_diehook  = olddiehook;
4041         /* XXX note that this croak may fail as we've already blown away
4042          * the stack - eg any nested evals */
4043         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4044     }
4045     JMPENV_POP;
4046     PL_dowarn   = oldwarn;
4047     PL_warnhook = oldwarnhook;
4048     PL_diehook  = olddiehook;
4049     PL_curcop = &PL_compiling;
4050
4051     if (PL_scopestack_ix > oldscope)
4052         delete_eval_scope();
4053
4054     if (ret)
4055         goto nope;
4056
4057     folded = cBOOL(o->op_folded);
4058     op_free(o);
4059     assert(sv);
4060     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
4061     else if (!SvIMMORTAL(sv)) {
4062         SvPADTMP_on(sv);
4063         SvREADONLY_on(sv);
4064     }
4065     if (type == OP_RV2GV)
4066         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
4067     else
4068     {
4069         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4070         /* OP_STRINGIFY and constant folding are used to implement qq.
4071            Here the constant folding is an implementation detail that we
4072            want to hide.  If the stringify op is itself already marked
4073            folded, however, then it is actually a folded join.  */
4074         if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
4075     }
4076     return newop;
4077
4078  nope:
4079     return o;
4080 }
4081
4082 static OP *
4083 S_gen_constant_list(pTHX_ OP *o)
4084 {
4085     dVAR;
4086     OP *curop;
4087     const SSize_t oldtmps_floor = PL_tmps_floor;
4088     SV **svp;
4089     AV *av;
4090
4091     list(o);
4092     if (PL_parser && PL_parser->error_count)
4093         return o;               /* Don't attempt to run with errors */
4094
4095     curop = LINKLIST(o);
4096     o->op_next = 0;
4097     CALL_PEEP(curop);
4098     S_prune_chain_head(&curop);
4099     PL_op = curop;
4100     Perl_pp_pushmark(aTHX);
4101     CALLRUNOPS(aTHX);
4102     PL_op = curop;
4103     assert (!(curop->op_flags & OPf_SPECIAL));
4104     assert(curop->op_type == OP_RANGE);
4105     Perl_pp_anonlist(aTHX);
4106     PL_tmps_floor = oldtmps_floor;
4107
4108     o->op_type = OP_RV2AV;
4109     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4110     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4111     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4112     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4113     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4114
4115     /* replace subtree with an OP_CONST */
4116     curop = ((UNOP*)o)->op_first;
4117     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4118     op_free(curop);
4119
4120     if (AvFILLp(av) != -1)
4121         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4122         {
4123             SvPADTMP_on(*svp);
4124             SvREADONLY_on(*svp);
4125         }
4126     LINKLIST(o);
4127     return list(o);
4128 }
4129
4130 /* convert o (and any siblings) into a list if not already, then
4131  * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
4132  */
4133
4134 OP *
4135 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
4136 {
4137     dVAR;
4138     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4139     if (!o || o->op_type != OP_LIST)
4140         o = force_list(o, 0);
4141     else
4142         o->op_flags &= ~OPf_WANT;
4143
4144     if (!(PL_opargs[type] & OA_MARK))
4145         op_null(cLISTOPo->op_first);
4146     else {
4147         OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
4148         if (kid2 && kid2->op_type == OP_COREARGS) {
4149             op_null(cLISTOPo->op_first);
4150             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4151         }
4152     }   
4153
4154     o->op_type = (OPCODE)type;
4155     o->op_ppaddr = PL_ppaddr[type];
4156     o->op_flags |= flags;
4157
4158     o = CHECKOP(type, o);
4159     if (o->op_type != (unsigned)type)
4160         return o;
4161
4162     return fold_constants(op_integerize(op_std_init(o)));
4163 }
4164
4165 /*
4166 =head1 Optree Manipulation Functions
4167 */
4168
4169 /* List constructors */
4170
4171 /*
4172 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4173
4174 Append an item to the list of ops contained directly within a list-type
4175 op, returning the lengthened list.  I<first> is the list-type op,
4176 and I<last> is the op to append to the list.  I<optype> specifies the
4177 intended opcode for the list.  If I<first> is not already a list of the
4178 right type, it will be upgraded into one.  If either I<first> or I<last>
4179 is null, the other is returned unchanged.
4180
4181 =cut
4182 */
4183
4184 OP *
4185 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4186 {
4187     if (!first)
4188         return last;
4189
4190     if (!last)
4191         return first;
4192
4193     if (first->op_type != (unsigned)type
4194         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4195     {
4196         return newLISTOP(type, 0, first, last);
4197     }
4198
4199     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4200     first->op_flags |= OPf_KIDS;
4201     return first;
4202 }
4203
4204 /*
4205 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4206
4207 Concatenate the lists of ops contained directly within two list-type ops,
4208 returning the combined list.  I<first> and I<last> are the list-type ops
4209 to concatenate.  I<optype> specifies the intended opcode for the list.
4210 If either I<first> or I<last> is not already a list of the right type,
4211 it will be upgraded into one.  If either I<first> or I<last> is null,
4212 the other is returned unchanged.
4213
4214 =cut
4215 */
4216
4217 OP *
4218 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4219 {
4220     if (!first)
4221         return last;
4222
4223     if (!last)
4224         return first;
4225
4226     if (first->op_type != (unsigned)type)
4227         return op_prepend_elem(type, first, last);
4228
4229     if (last->op_type != (unsigned)type)
4230         return op_append_elem(type, first, last);
4231
4232     ((LISTOP*)first)->op_last->op_lastsib = 0;
4233     OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4234     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4235     ((LISTOP*)first)->op_last->op_lastsib = 1;
4236 #ifdef PERL_OP_PARENT
4237     ((LISTOP*)first)->op_last->op_sibling = first;
4238 #endif
4239     first->op_flags |= (last->op_flags & OPf_KIDS);
4240
4241
4242     S_op_destroy(aTHX_ last);
4243
4244     return first;
4245 }
4246
4247 /*
4248 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4249
4250 Prepend an item to the list of ops contained directly within a list-type
4251 op, returning the lengthened list.  I<first> is the op to prepend to the
4252 list, and I<last> is the list-type op.  I<optype> specifies the intended
4253 opcode for the list.  If I<last> is not already a list of the right type,
4254 it will be upgraded into one.  If either I<first> or I<last> is null,
4255 the other is returned unchanged.
4256
4257 =cut
4258 */
4259
4260 OP *
4261 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4262 {
4263     if (!first)
4264         return last;
4265
4266     if (!last)
4267         return first;
4268
4269     if (last->op_type == (unsigned)type) {
4270         if (type == OP_LIST) {  /* already a PUSHMARK there */
4271             /* insert 'first' after pushmark */
4272             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4273             if (!(first->op_flags & OPf_PARENS))
4274                 last->op_flags &= ~OPf_PARENS;
4275         }
4276         else
4277             op_sibling_splice(last, NULL, 0, first);
4278         last->op_flags |= OPf_KIDS;
4279         return last;
4280     }
4281
4282     return newLISTOP(type, 0, first, last);
4283 }
4284
4285 /* Constructors */
4286
4287
4288 /*
4289 =head1 Optree construction
4290
4291 =for apidoc Am|OP *|newNULLLIST
4292
4293 Constructs, checks, and returns a new C<stub> op, which represents an
4294 empty list expression.
4295
4296 =cut
4297 */
4298
4299 OP *
4300 Perl_newNULLLIST(pTHX)
4301 {
4302     return newOP(OP_STUB, 0);
4303 }
4304
4305 /* promote o and any siblings to be a list if its not already; i.e.
4306  *
4307  *  o - A - B
4308  *
4309  * becomes
4310  *
4311  *  list
4312  *    |
4313  *  pushmark - o - A - B
4314  *
4315  * If nullit it true, the list op is nulled.
4316  */
4317
4318 static OP *
4319 S_force_list(pTHX_ OP *o, bool nullit)
4320 {
4321     if (!o || o->op_type != OP_LIST) {
4322         OP *rest = NULL;
4323         if (o) {
4324             /* manually detach any siblings then add them back later */
4325             rest = OP_SIBLING(o);
4326             OP_SIBLING_set(o, NULL);
4327             o->op_lastsib = 1;
4328         }
4329         o = newLISTOP(OP_LIST, 0, o, NULL);
4330         if (rest)
4331             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4332     }
4333     if (nullit)
4334         op_null(o);
4335     return o;
4336 }
4337
4338 /*
4339 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4340
4341 Constructs, checks, and returns an op of any list type.  I<type> is
4342 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4343 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4344 supply up to two ops to be direct children of the list op; they are
4345 consumed by this function and become part of the constructed op tree.
4346
4347 =cut
4348 */
4349
4350 OP *
4351 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4352 {
4353     dVAR;
4354     LISTOP *listop;
4355
4356     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4357
4358     NewOp(1101, listop, 1, LISTOP);
4359
4360     listop->op_type = (OPCODE)type;
4361     listop->op_ppaddr = PL_ppaddr[type];
4362     if (first || last)
4363         flags |= OPf_KIDS;
4364     listop->op_flags = (U8)flags;
4365
4366     if (!last && first)
4367         last = first;
4368     else if (!first && last)
4369         first = last;
4370     else if (first)
4371         OP_SIBLING_set(first, last);
4372     listop->op_first = first;
4373     listop->op_last = last;
4374     if (type == OP_LIST) {
4375         OP* const pushop = newOP(OP_PUSHMARK, 0);
4376         pushop->op_lastsib = 0;
4377         OP_SIBLING_set(pushop, first);
4378         listop->op_first = pushop;
4379         listop->op_flags |= OPf_KIDS;
4380         if (!last)
4381             listop->op_last = pushop;
4382     }
4383     if (first)
4384         first->op_lastsib = 0;
4385     if (listop->op_last) {
4386         listop->op_last->op_lastsib = 1;
4387 #ifdef PERL_OP_PARENT
4388         listop->op_last->op_sibling = (OP*)listop;
4389 #endif
4390     }
4391
4392     return CHECKOP(type, listop);
4393 }
4394
4395 /*
4396 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4397
4398 Constructs, checks, and returns an op of any base type (any type that
4399 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4400 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4401 of C<op_private>.
4402
4403 =cut
4404 */
4405
4406 OP *
4407 Perl_newOP(pTHX_ I32 type, I32 flags)
4408 {
4409     dVAR;
4410     OP *o;
4411
4412     if (type == -OP_ENTEREVAL) {
4413         type = OP_ENTEREVAL;
4414         flags |= OPpEVAL_BYTES<<8;
4415     }
4416
4417     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4418         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4419         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4420         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4421
4422     NewOp(1101, o, 1, OP);
4423     o->op_type = (OPCODE)type;
4424     o->op_ppaddr = PL_ppaddr[type];
4425     o->op_flags = (U8)flags;
4426
4427     o->op_next = o;
4428     o->op_private = (U8)(0 | (flags >> 8));
4429     if (PL_opargs[type] & OA_RETSCALAR)
4430         scalar(o);
4431     if (PL_opargs[type] & OA_TARGET)
4432         o->op_targ = pad_alloc(type, SVs_PADTMP);
4433     return CHECKOP(type, o);
4434 }
4435
4436 /*
4437 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4438
4439 Constructs, checks, and returns an op of any unary type.  I<type> is
4440 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4441 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4442 bits, the eight bits of C<op_private>, except that the bit with value 1
4443 is automatically set.  I<first> supplies an optional op to be the direct
4444 child of the unary op; it is consumed by this function and become part
4445 of the constructed op tree.
4446
4447 =cut
4448 */
4449
4450 OP *
4451 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4452 {
4453     dVAR;
4454     UNOP *unop;
4455
4456     if (type == -OP_ENTEREVAL) {
4457         type = OP_ENTEREVAL;
4458         flags |= OPpEVAL_BYTES<<8;
4459     }
4460
4461     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4462         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4463         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4464         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4465         || type == OP_SASSIGN
4466         || type == OP_ENTERTRY
4467         || type == OP_NULL );
4468
4469     if (!first)
4470         first = newOP(OP_STUB, 0);
4471     if (PL_opargs[type] & OA_MARK)
4472         first = force_list(first, 1);
4473
4474     NewOp(1101, unop, 1, UNOP);
4475     unop->op_type = (OPCODE)type;
4476     unop->op_ppaddr = PL_ppaddr[type];
4477     unop->op_first = first;
4478     unop->op_flags = (U8)(flags | OPf_KIDS);
4479     unop->op_private = (U8)(1 | (flags >> 8));
4480
4481 #ifdef PERL_OP_PARENT
4482     if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4483         first->op_sibling = (OP*)unop;
4484 #endif
4485
4486     unop = (UNOP*) CHECKOP(type, unop);
4487     if (unop->op_next)
4488         return (OP*)unop;
4489
4490     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4491 }
4492
4493 /*
4494 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4495
4496 Constructs, checks, and returns an op of method type with a method name
4497 evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
4498 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4499 and, shifted up eight bits, the eight bits of C<op_private>, except that
4500 the bit with value 1 is automatically set. I<dynamic_meth> supplies an
4501 op which evaluates method name; it is consumed by this function and
4502 become part of the constructed op tree.
4503 Supported optypes: OP_METHOD.
4504
4505 =cut
4506 */
4507
4508 static OP*
4509 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4510     dVAR;
4511     METHOP *methop;
4512
4513     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP);
4514
4515     NewOp(1101, methop, 1, METHOP);
4516     if (dynamic_meth) {
4517         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4518         methop->op_flags = (U8)(flags | OPf_KIDS);
4519         methop->op_u.op_first = dynamic_meth;
4520         methop->op_private = (U8)(1 | (flags >> 8));
4521     }
4522     else {
4523         assert(const_meth);
4524         methop->op_flags = (U8)(flags & ~OPf_KIDS);
4525         methop->op_u.op_meth_sv = const_meth;
4526         methop->op_private = (U8)(0 | (flags >> 8));
4527         methop->op_next = (OP*)methop;
4528     }
4529
4530     methop->op_type = (OPCODE)type;
4531     methop->op_ppaddr = PL_ppaddr[type];
4532     methop = (METHOP*) CHECKOP(type, methop);
4533
4534     if (methop->op_next) return (OP*)methop;
4535
4536     return fold_constants(op_integerize(op_std_init((OP *) methop)));
4537 }
4538
4539 OP *
4540 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4541     PERL_ARGS_ASSERT_NEWMETHOP;
4542     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4543 }
4544
4545 /*
4546 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4547
4548 Constructs, checks, and returns an op of method type with a constant
4549 method name. I<type> is the opcode. I<flags> gives the eight bits of
4550 C<op_flags>, and, shifted up eight bits, the eight bits of
4551 C<op_private>. I<const_meth> supplies a constant method name;
4552 it must be a shared COW string.
4553 Supported optypes: OP_METHOD_NAMED.
4554
4555 =cut
4556 */
4557
4558 OP *
4559 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4560     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4561     return newMETHOP_internal(type, flags, NULL, const_meth);
4562 }
4563
4564 /*
4565 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4566
4567 Constructs, checks, and returns an op of any binary type.  I<type>
4568 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4569 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4570 the eight bits of C<op_private>, except that the bit with value 1 or
4571 2 is automatically set as required.  I<first> and I<last> supply up to
4572 two ops to be the direct children of the binary op; they are consumed
4573 by this function and become part of the constructed op tree.
4574
4575 =cut
4576 */
4577
4578 OP *
4579 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4580 {
4581     dVAR;
4582     BINOP *binop;
4583
4584     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4585         || type == OP_SASSIGN || type == OP_NULL );
4586
4587     NewOp(1101, binop, 1, BINOP);
4588
4589     if (!first)
4590         first = newOP(OP_NULL, 0);
4591
4592     binop->op_type = (OPCODE)type;
4593     binop->op_ppaddr = PL_ppaddr[type];
4594     binop->op_first = first;
4595     binop->op_flags = (U8)(flags | OPf_KIDS);
4596     if (!last) {
4597         last = first;
4598         binop->op_private = (U8)(1 | (flags >> 8));
4599     }
4600     else {
4601         binop->op_private = (U8)(2 | (flags >> 8));
4602         OP_SIBLING_set(first, last);
4603         first->op_lastsib = 0;
4604     }
4605
4606 #ifdef PERL_OP_PARENT
4607     if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4608         last->op_sibling = (OP*)binop;
4609 #endif
4610
4611     binop->op_last = OP_SIBLING(binop->op_first);
4612 #ifdef PERL_OP_PARENT
4613     if (binop->op_last)
4614         binop->op_last->op_sibling = (OP*)binop;
4615 #endif
4616
4617     binop = (BINOP*)CHECKOP(type, binop);
4618     if (binop->op_next || binop->op_type != (OPCODE)type)
4619         return (OP*)binop;
4620
4621     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4622 }
4623
4624 static int uvcompare(const void *a, const void *b)
4625     __attribute__nonnull__(1)
4626     __attribute__nonnull__(2)
4627     __attribute__pure__;
4628 static int uvcompare(const void *a, const void *b)
4629 {
4630     if (*((const UV *)a) < (*(const UV *)b))
4631         return -1;
4632     if (*((const UV *)a) > (*(const UV *)b))
4633         return 1;
4634     if (*((const UV *)a+1) < (*(const UV *)b+1))
4635         return -1;
4636     if (*((const UV *)a+1) > (*(const UV *)b+1))
4637         return 1;
4638     return 0;
4639 }
4640
4641 static OP *
4642 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4643 {
4644     SV * const tstr = ((SVOP*)expr)->op_sv;
4645     SV * const rstr =
4646                               ((SVOP*)repl)->op_sv;
4647     STRLEN tlen;
4648     STRLEN rlen;
4649     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4650     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4651     I32 i;
4652     I32 j;
4653     I32 grows = 0;
4654     short *tbl;
4655
4656     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4657     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4658     I32 del              = o->op_private & OPpTRANS_DELETE;
4659     SV* swash;
4660
4661     PERL_ARGS_ASSERT_PMTRANS;
4662
4663     PL_hints |= HINT_BLOCK_SCOPE;
4664
4665     if (SvUTF8(tstr))
4666         o->op_private |= OPpTRANS_FROM_UTF;
4667
4668     if (SvUTF8(rstr))
4669         o->op_private |= OPpTRANS_TO_UTF;
4670
4671     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4672         SV* const listsv = newSVpvs("# comment\n");
4673         SV* transv = NULL;
4674         const U8* tend = t + tlen;
4675         const U8* rend = r + rlen;
4676         STRLEN ulen;
4677         UV tfirst = 1;
4678         UV tlast = 0;
4679         IV tdiff;
4680         UV rfirst = 1;
4681         UV rlast = 0;
4682         IV rdiff;
4683         IV diff;
4684         I32 none = 0;
4685         U32 max = 0;
4686         I32 bits;
4687         I32 havefinal = 0;
4688         U32 final = 0;
4689         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4690         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4691         U8* tsave = NULL;
4692         U8* rsave = NULL;
4693         const U32 flags = UTF8_ALLOW_DEFAULT;
4694
4695         if (!from_utf) {
4696             STRLEN len = tlen;
4697             t = tsave = bytes_to_utf8(t, &len);
4698             tend = t + len;
4699         }
4700         if (!to_utf && rlen) {
4701             STRLEN len = rlen;
4702             r = rsave = bytes_to_utf8(r, &len);
4703             rend = r + len;
4704         }
4705
4706 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4707  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4708  * odd.  */
4709
4710         if (complement) {
4711             U8 tmpbuf[UTF8_MAXBYTES+1];
4712             UV *cp;
4713             UV nextmin = 0;
4714             Newx(cp, 2*tlen, UV);
4715             i = 0;
4716             transv = newSVpvs("");
4717             while (t < tend) {
4718                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4719                 t += ulen;
4720                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4721                     t++;
4722                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4723                     t += ulen;
4724                 }
4725                 else {
4726                  cp[2*i+1] = cp[2*i];
4727                 }
4728                 i++;
4729             }
4730             qsort(cp, i, 2*sizeof(UV), uvcompare);
4731             for (j = 0; j < i; j++) {
4732                 UV  val = cp[2*j];
4733                 diff = val - nextmin;
4734                 if (diff > 0) {
4735                     t = uvchr_to_utf8(tmpbuf,nextmin);
4736                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4737                     if (diff > 1) {
4738                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4739                         t = uvchr_to_utf8(tmpbuf, val - 1);
4740                         sv_catpvn(transv, (char *)&range_mark, 1);
4741                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4742                     }
4743                 }
4744                 val = cp[2*j+1];
4745                 if (val >= nextmin)
4746                     nextmin = val + 1;
4747             }
4748             t = uvchr_to_utf8(tmpbuf,nextmin);
4749             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4750             {
4751                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4752                 sv_catpvn(transv, (char *)&range_mark, 1);
4753             }
4754             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4755             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4756             t = (const U8*)SvPVX_const(transv);
4757             tlen = SvCUR(transv);
4758             tend = t + tlen;
4759             Safefree(cp);
4760         }
4761         else if (!rlen && !del) {
4762             r = t; rlen = tlen; rend = tend;
4763         }
4764         if (!squash) {
4765                 if ((!rlen && !del) || t == r ||
4766                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4767                 {
4768                     o->op_private |= OPpTRANS_IDENTICAL;
4769                 }
4770         }
4771
4772         while (t < tend || tfirst <= tlast) {
4773             /* see if we need more "t" chars */
4774             if (tfirst > tlast) {
4775                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4776                 t += ulen;
4777                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4778                     t++;
4779                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4780                     t += ulen;
4781                 }
4782                 else
4783                     tlast = tfirst;
4784             }
4785
4786             /* now see if we need more "r" chars */
4787             if (rfirst > rlast) {
4788                 if (r < rend) {
4789                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4790                     r += ulen;
4791                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4792                         r++;
4793                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4794                         r += ulen;
4795                     }
4796                     else
4797                         rlast = rfirst;
4798                 }
4799                 else {
4800                     if (!havefinal++)
4801                         final = rlast;
4802                     rfirst = rlast = 0xffffffff;
4803                 }
4804             }
4805
4806             /* now see which range will peter our first, if either. */
4807             tdiff = tlast - tfirst;
4808             rdiff = rlast - rfirst;
4809
4810             if (tdiff <= rdiff)
4811                 diff = tdiff;
4812             else
4813                 diff = rdiff;
4814
4815             if (rfirst == 0xffffffff) {
4816                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4817                 if (diff > 0)
4818                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4819                                    (long)tfirst, (long)tlast);
4820                 else
4821                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4822             }
4823             else {
4824                 if (diff > 0)
4825                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4826                                    (long)tfirst, (long)(tfirst + diff),
4827                                    (long)rfirst);
4828                 else
4829                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4830                                    (long)tfirst, (long)rfirst);
4831
4832                 if (rfirst + diff > max)
4833                     max = rfirst + diff;
4834                 if (!grows)
4835                     grows = (tfirst < rfirst &&
4836                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4837                 rfirst += diff + 1;
4838             }
4839             tfirst += diff + 1;
4840         }
4841
4842         none = ++max;
4843         if (del)
4844             del = ++max;
4845
4846         if (max > 0xffff)
4847             bits = 32;
4848         else if (max > 0xff)
4849             bits = 16;
4850         else
4851             bits = 8;
4852
4853         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4854 #ifdef USE_ITHREADS
4855         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4856         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4857         PAD_SETSV(cPADOPo->op_padix, swash);
4858         SvPADTMP_on(swash);
4859         SvREADONLY_on(swash);
4860 #else
4861         cSVOPo->op_sv = swash;
4862 #endif
4863         SvREFCNT_dec(listsv);
4864         SvREFCNT_dec(transv);
4865
4866         if (!del && havefinal && rlen)
4867             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4868                            newSVuv((UV)final), 0);
4869
4870         if (grows)
4871             o->op_private |= OPpTRANS_GROWS;
4872
4873         Safefree(tsave);
4874         Safefree(rsave);
4875
4876         op_free(expr);
4877         op_free(repl);
4878         return o;
4879     }
4880
4881     tbl = (short*)PerlMemShared_calloc(
4882         (o->op_private & OPpTRANS_COMPLEMENT) &&
4883             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4884         sizeof(short));
4885     cPVOPo->op_pv = (char*)tbl;
4886     if (complement) {
4887         for (i = 0; i < (I32)tlen; i++)
4888             tbl[t[i]] = -1;
4889         for (i = 0, j = 0; i < 256; i++) {
4890             if (!tbl[i]) {
4891                 if (j >= (I32)rlen) {
4892                     if (del)
4893                         tbl[i] = -2;
4894                     else if (rlen)
4895                         tbl[i] = r[j-1];
4896                     else
4897                         tbl[i] = (short)i;
4898                 }
4899                 else {
4900                     if (i < 128 && r[j] >= 128)
4901                         grows = 1;
4902                     tbl[i] = r[j++];
4903                 }
4904             }
4905         }
4906         if (!del) {
4907             if (!rlen) {
4908                 j = rlen;
4909                 if (!squash)
4910                     o->op_private |= OPpTRANS_IDENTICAL;
4911             }
4912             else if (j >= (I32)rlen)
4913                 j = rlen - 1;
4914             else {
4915                 tbl = 
4916                     (short *)
4917                     PerlMemShared_realloc(tbl,
4918                                           (0x101+rlen-j) * sizeof(short));
4919                 cPVOPo->op_pv = (char*)tbl;
4920             }
4921             tbl[0x100] = (short)(rlen - j);
4922             for (i=0; i < (I32)rlen - j; i++)
4923                 tbl[0x101+i] = r[j+i];
4924         }
4925     }
4926     else {
4927         if (!rlen && !del) {
4928             r = t; rlen = tlen;
4929             if (!squash)
4930                 o->op_private |= OPpTRANS_IDENTICAL;
4931         }
4932         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4933             o->op_private |= OPpTRANS_IDENTICAL;
4934         }
4935         for (i = 0; i < 256; i++)
4936             tbl[i] = -1;
4937         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4938             if (j >= (I32)rlen) {
4939                 if (del) {
4940                     if (tbl[t[i]] == -1)
4941                         tbl[t[i]] = -2;
4942                     continue;
4943                 }
4944                 --j;
4945             }
4946             if (tbl[t[i]] == -1) {
4947                 if (t[i] < 128 && r[j] >= 128)
4948                     grows = 1;
4949                 tbl[t[i]] = r[j];
4950             }
4951         }
4952     }
4953
4954     if(del && rlen == tlen) {
4955         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
4956     } else if(rlen > tlen && !complement) {
4957         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4958     }
4959
4960     if (grows)
4961         o->op_private |= OPpTRANS_GROWS;
4962     op_free(expr);
4963     op_free(repl);
4964
4965     return o;
4966 }
4967
4968 /*
4969 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4970
4971 Constructs, checks, and returns an op of any pattern matching type.
4972 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4973 and, shifted up eight bits, the eight bits of C<op_private>.
4974
4975 =cut
4976 */
4977
4978 OP *
4979 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4980 {
4981     dVAR;
4982     PMOP *pmop;
4983
4984     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4985
4986     NewOp(1101, pmop, 1, PMOP);
4987     pmop->op_type = (OPCODE)type;
4988     pmop->op_ppaddr = PL_ppaddr[type];
4989     pmop->op_flags = (U8)flags;
4990     pmop->op_private = (U8)(0 | (flags >> 8));
4991
4992     if (PL_hints & HINT_RE_TAINT)
4993         pmop->op_pmflags |= PMf_RETAINT;
4994 #ifdef USE_LOCALE_CTYPE
4995     if (IN_LC_COMPILETIME(LC_CTYPE)) {
4996         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4997     }
4998     else
4999 #endif
5000          if (IN_UNI_8_BIT) {
5001         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
5002     }
5003     if (PL_hints & HINT_RE_FLAGS) {
5004         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5005          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
5006         );
5007         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
5008         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
5009          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
5010         );
5011         if (reflags && SvOK(reflags)) {
5012             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
5013         }
5014     }
5015
5016
5017 #ifdef USE_ITHREADS
5018     assert(SvPOK(PL_regex_pad[0]));
5019     if (SvCUR(PL_regex_pad[0])) {
5020         /* Pop off the "packed" IV from the end.  */
5021         SV *const repointer_list = PL_regex_pad[0];
5022         const char *p = SvEND(repointer_list) - sizeof(IV);
5023         const IV offset = *((IV*)p);
5024
5025         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5026
5027         SvEND_set(repointer_list, p);
5028
5029         pmop->op_pmoffset = offset;
5030         /* This slot should be free, so assert this:  */
5031         assert(PL_regex_pad[offset] == &PL_sv_undef);
5032     } else {
5033         SV * const repointer = &PL_sv_undef;
5034         av_push(PL_regex_padav, repointer);
5035         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5036         PL_regex_pad = AvARRAY(PL_regex_padav);
5037     }
5038 #endif
5039
5040     return CHECKOP(type, pmop);
5041 }
5042
5043 /* Given some sort of match op o, and an expression expr containing a
5044  * pattern, either compile expr into a regex and attach it to o (if it's
5045  * constant), or convert expr into a runtime regcomp op sequence (if it's
5046  * not)
5047  *
5048  * isreg indicates that the pattern is part of a regex construct, eg
5049  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5050  * split "pattern", which aren't. In the former case, expr will be a list
5051  * if the pattern contains more than one term (eg /a$b/) or if it contains
5052  * a replacement, ie s/// or tr///.
5053  *
5054  * When the pattern has been compiled within a new anon CV (for
5055  * qr/(?{...})/ ), then floor indicates the savestack level just before
5056  * the new sub was created
5057  */
5058
5059 OP *
5060 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
5061 {
5062     dVAR;
5063     PMOP *pm;
5064     LOGOP *rcop;
5065     I32 repl_has_vars = 0;
5066     OP* repl = NULL;
5067     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5068     bool is_compiletime;
5069     bool has_code;
5070
5071     PERL_ARGS_ASSERT_PMRUNTIME;
5072
5073     /* for s/// and tr///, last element in list is the replacement; pop it */
5074
5075     if (is_trans || o->op_type == OP_SUBST) {
5076         OP* kid;
5077         repl = cLISTOPx(expr)->op_last;
5078         kid = cLISTOPx(expr)->op_first;
5079         while (OP_SIBLING(kid) != repl)
5080             kid = OP_SIBLING(kid);
5081         op_sibling_splice(expr, kid, 1, NULL);
5082     }
5083
5084     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
5085
5086     if (is_trans) {
5087         OP *first, *last;
5088
5089         assert(expr->op_type == OP_LIST);
5090         first = cLISTOPx(expr)->op_first;
5091         last  = cLISTOPx(expr)->op_last;
5092         assert(first->op_type == OP_PUSHMARK);
5093         assert(OP_SIBLING(first) == last);
5094
5095         /* cut 'last' from sibling chain, then free everything else */
5096         op_sibling_splice(expr, first, 1, NULL);
5097         op_free(expr);
5098
5099         return pmtrans(o, last, repl);
5100     }
5101
5102     /* find whether we have any runtime or code elements;
5103      * at the same time, temporarily set the op_next of each DO block;
5104      * then when we LINKLIST, this will cause the DO blocks to be excluded
5105      * from the op_next chain (and from having LINKLIST recursively
5106      * applied to them). We fix up the DOs specially later */
5107
5108     is_compiletime = 1;
5109     has_code = 0;
5110     if (expr->op_type == OP_LIST) {
5111         OP *o;
5112         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5113             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5114                 has_code = 1;
5115                 assert(!o->op_next);
5116                 if (UNLIKELY(!OP_HAS_SIBLING(o))) {
5117                     assert(PL_parser && PL_parser->error_count);
5118                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5119                        the op we were expecting to see, to avoid crashing
5120                        elsewhere.  */
5121                     op_sibling_splice(expr, o, 0,
5122                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5123                 }
5124                 o->op_next = OP_SIBLING(o);
5125             }
5126             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5127                 is_compiletime = 0;
5128         }
5129     }
5130     else if (expr->op_type != OP_CONST)
5131         is_compiletime = 0;
5132
5133     LINKLIST(expr);
5134
5135     /* fix up DO blocks; treat each one as a separate little sub;
5136      * also, mark any arrays as LIST/REF */
5137
5138     if (expr->op_type == OP_LIST) {
5139         OP *o;
5140         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5141
5142             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5143                 assert( !(o->op_flags  & OPf_WANT));
5144                 /* push the array rather than its contents. The regex
5145                  * engine will retrieve and join the elements later */
5146                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5147                 continue;
5148             }
5149
5150             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5151                 continue;
5152             o->op_next = NULL; /* undo temporary hack from above */
5153             scalar(o);
5154             LINKLIST(o);
5155             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5156                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5157                 /* skip ENTER */
5158                 assert(leaveop->op_first->op_type == OP_ENTER);
5159                 assert(OP_HAS_SIBLING(leaveop->op_first));
5160                 o->op_next = OP_SIBLING(leaveop->op_first);
5161                 /* skip leave */
5162                 assert(leaveop->op_flags & OPf_KIDS);
5163                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5164                 leaveop->op_next = NULL; /* stop on last op */
5165                 op_null((OP*)leaveop);
5166             }
5167             else {
5168                 /* skip SCOPE */
5169                 OP *scope = cLISTOPo->op_first;
5170                 assert(scope->op_type == OP_SCOPE);
5171                 assert(scope->op_flags & OPf_KIDS);
5172                 scope->op_next = NULL; /* stop on last op */
5173                 op_null(scope);
5174             }
5175             /* have to peep the DOs individually as we've removed it from
5176              * the op_next chain */
5177             CALL_PEEP(o);
5178             S_prune_chain_head(&(o->op_next));
5179             if (is_compiletime)
5180                 /* runtime finalizes as part of finalizing whole tree */
5181                 finalize_optree(o);
5182         }
5183     }
5184     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5185         assert( !(expr->op_flags  & OPf_WANT));
5186         /* push the array rather than its contents. The regex
5187          * engine will retrieve and join the elements later */
5188         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5189     }
5190
5191     PL_hints |= HINT_BLOCK_SCOPE;
5192     pm = (PMOP*)o;
5193     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5194
5195     if (is_compiletime) {
5196         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5197         regexp_engine const *eng = current_re_engine();
5198
5199         if (o->op_flags & OPf_SPECIAL)
5200             rx_flags |= RXf_SPLIT;
5201
5202         if (!has_code || !eng->op_comp) {
5203             /* compile-time simple constant pattern */
5204
5205             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5206                 /* whoops! we guessed that a qr// had a code block, but we
5207                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5208                  * that isn't required now. Note that we have to be pretty
5209                  * confident that nothing used that CV's pad while the
5210                  * regex was parsed */
5211                 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
5212                 /* But we know that one op is using this CV's slab. */
5213                 cv_forget_slab(PL_compcv);
5214                 LEAVE_SCOPE(floor);
5215                 pm->op_pmflags &= ~PMf_HAS_CV;
5216             }
5217
5218             PM_SETRE(pm,
5219                 eng->op_comp
5220                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5221                                         rx_flags, pm->op_pmflags)
5222                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5223                                         rx_flags, pm->op_pmflags)
5224             );
5225             op_free(expr);
5226         }
5227         else {
5228             /* compile-time pattern that includes literal code blocks */
5229             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5230                         rx_flags,
5231                         (pm->op_pmflags |
5232                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5233                     );
5234             PM_SETRE(pm, re);
5235             if (pm->op_pmflags & PMf_HAS_CV) {
5236                 CV *cv;
5237                 /* this QR op (and the anon sub we embed it in) is never
5238                  * actually executed. It's just a placeholder where we can
5239                  * squirrel away expr in op_code_list without the peephole
5240                  * optimiser etc processing it for a second time */
5241                 OP *qr = newPMOP(OP_QR, 0);
5242                 ((PMOP*)qr)->op_code_list = expr;
5243
5244                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5245                 SvREFCNT_inc_simple_void(PL_compcv);
5246                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5247                 ReANY(re)->qr_anoncv = cv;
5248
5249                 /* attach the anon CV to the pad so that
5250                  * pad_fixup_inner_anons() can find it */
5251                 (void)pad_add_anon(cv, o->op_type);
5252                 SvREFCNT_inc_simple_void(cv);
5253             }
5254             else {
5255                 pm->op_code_list = expr;
5256             }
5257         }
5258     }
5259     else {
5260         /* runtime pattern: build chain of regcomp etc ops */
5261         bool reglist;
5262         PADOFFSET cv_targ = 0;
5263
5264         reglist = isreg && expr->op_type == OP_LIST;
5265         if (reglist)
5266             op_null(expr);
5267
5268         if (has_code) {
5269             pm->op_code_list = expr;
5270             /* don't free op_code_list; its ops are embedded elsewhere too */
5271             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5272         }
5273
5274         if (o->op_flags & OPf_SPECIAL)
5275             pm->op_pmflags |= PMf_SPLIT;
5276
5277         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5278          * to allow its op_next to be pointed past the regcomp and
5279          * preceding stacking ops;
5280          * OP_REGCRESET is there to reset taint before executing the
5281          * stacking ops */
5282         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5283             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5284
5285         if (pm->op_pmflags & PMf_HAS_CV) {
5286             /* we have a runtime qr with literal code. This means
5287              * that the qr// has been wrapped in a new CV, which
5288              * means that runtime consts, vars etc will have been compiled
5289              * against a new pad. So... we need to execute those ops
5290              * within the environment of the new CV. So wrap them in a call
5291              * to a new anon sub. i.e. for
5292              *
5293              *     qr/a$b(?{...})/,
5294              *
5295              * we build an anon sub that looks like
5296              *
5297              *     sub { "a", $b, '(?{...})' }
5298              *
5299              * and call it, passing the returned list to regcomp.
5300              * Or to put it another way, the list of ops that get executed
5301              * are:
5302              *
5303              *     normal              PMf_HAS_CV
5304              *     ------              -------------------
5305              *                         pushmark (for regcomp)
5306              *                         pushmark (for entersub)
5307              *                         anoncode
5308              *                         srefgen
5309              *                         entersub
5310              *     regcreset                  regcreset
5311              *     pushmark                   pushmark
5312              *     const("a")                 const("a")
5313              *     gvsv(b)                    gvsv(b)
5314              *     const("(?{...})")          const("(?{...})")
5315              *                                leavesub
5316              *     regcomp             regcomp
5317              */
5318
5319             SvREFCNT_inc_simple_void(PL_compcv);
5320             /* these lines are just an unrolled newANONATTRSUB */
5321             expr = newSVOP(OP_ANONCODE, 0,
5322                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5323             cv_targ = expr->op_targ;
5324             expr = newUNOP(OP_REFGEN, 0, expr);
5325
5326             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5327         }
5328
5329         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5330         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
5331         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5332                            | (reglist ? OPf_STACKED : 0);
5333         rcop->op_targ = cv_targ;
5334
5335         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5336         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
5337
5338         /* establish postfix order */
5339         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5340             LINKLIST(expr);
5341             rcop->op_next = expr;
5342             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5343         }
5344         else {
5345             rcop->op_next = LINKLIST(expr);
5346             expr->op_next = (OP*)rcop;
5347         }
5348
5349         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5350     }
5351
5352     if (repl) {
5353         OP *curop = repl;
5354         bool konst;
5355         /* If we are looking at s//.../e with a single statement, get past
5356            the implicit do{}. */
5357         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5358              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5359              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5360          {
5361             OP *sib;
5362             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5363             if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid))
5364                      && !OP_HAS_SIBLING(sib))
5365                 curop = sib;
5366         }
5367         if (curop->op_type == OP_CONST)
5368             konst = TRUE;
5369         else if (( (curop->op_type == OP_RV2SV ||
5370                     curop->op_type == OP_RV2AV ||
5371                     curop->op_type == OP_RV2HV ||
5372                     curop->op_type == OP_RV2GV)
5373                    && cUNOPx(curop)->op_first
5374                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5375                 || curop->op_type == OP_PADSV
5376                 || curop->op_type == OP_PADAV
5377                 || curop->op_type == OP_PADHV
5378                 || curop->op_type == OP_PADANY) {
5379             repl_has_vars = 1;
5380             konst = TRUE;
5381         }
5382         else konst = FALSE;
5383         if (konst
5384             && !(repl_has_vars
5385                  && (!PM_GETRE(pm)
5386                      || !RX_PRELEN(PM_GETRE(pm))
5387                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5388         {
5389             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5390             op_prepend_elem(o->op_type, scalar(repl), o);
5391         }
5392         else {
5393             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5394             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
5395             rcop->op_private = 1;
5396
5397             /* establish postfix order */
5398             rcop->op_next = LINKLIST(repl);
5399             repl->op_next = (OP*)rcop;
5400
5401             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5402             assert(!(pm->op_pmflags & PMf_ONCE));
5403             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5404             rcop->op_next = 0;
5405         }
5406     }
5407
5408     return (OP*)pm;
5409 }
5410
5411 /*
5412 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5413
5414 Constructs, checks, and returns an op of any type that involves an
5415 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
5416 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
5417 takes ownership of one reference to it.
5418
5419 =cut
5420 */
5421
5422 OP *
5423 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5424 {
5425     dVAR;
5426     SVOP *svop;
5427
5428     PERL_ARGS_ASSERT_NEWSVOP;
5429
5430     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5431         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5432         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5433
5434     NewOp(1101, svop, 1, SVOP);
5435     svop->op_type = (OPCODE)type;
5436     svop->op_ppaddr = PL_ppaddr[type];
5437     svop->op_sv = sv;
5438     svop->op_next = (OP*)svop;
5439     svop->op_flags = (U8)flags;
5440     svop->op_private = (U8)(0 | (flags >> 8));
5441     if (PL_opargs[type] & OA_RETSCALAR)
5442         scalar((OP*)svop);
5443     if (PL_opargs[type] & OA_TARGET)
5444         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5445     return CHECKOP(type, svop);
5446 }
5447
5448 #ifdef USE_ITHREADS
5449
5450 /*
5451 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5452
5453 Constructs, checks, and returns an op of any type that involves a
5454 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
5455 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5456 is populated with I<sv>; this function takes ownership of one reference
5457 to it.
5458
5459 This function only exists if Perl has been compiled to use ithreads.
5460
5461 =cut
5462 */
5463
5464 OP *
5465 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5466 {
5467     dVAR;
5468     PADOP *padop;
5469
5470     PERL_ARGS_ASSERT_NEWPADOP;
5471
5472     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5473         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5474         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5475
5476     NewOp(1101, padop, 1, PADOP);
5477     padop->op_type = (OPCODE)type;
5478     padop->op_ppaddr = PL_ppaddr[type];
5479     padop->op_padix =
5480         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5481     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5482     PAD_SETSV(padop->op_padix, sv);
5483     assert(sv);
5484     padop->op_next = (OP*)padop;
5485     padop->op_flags = (U8)flags;
5486     if (PL_opargs[type] & OA_RETSCALAR)
5487         scalar((OP*)padop);
5488     if (PL_opargs[type] & OA_TARGET)
5489         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5490     return CHECKOP(type, padop);
5491 }
5492
5493 #endif /* USE_ITHREADS */
5494
5495 /*
5496 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5497
5498 Constructs, checks, and returns an op of any type that involves an
5499 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
5500 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
5501 reference; calling this function does not transfer ownership of any
5502 reference to it.
5503
5504 =cut
5505 */
5506
5507 OP *
5508 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5509 {
5510     PERL_ARGS_ASSERT_NEWGVOP;
5511
5512 #ifdef USE_ITHREADS
5513     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5514 #else
5515     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5516 #endif
5517 }
5518
5519 /*
5520 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5521
5522 Constructs, checks, and returns an op of any type that involves an
5523 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
5524 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
5525 must have been allocated using C<PerlMemShared_malloc>; the memory will
5526 be freed when the op is destroyed.
5527
5528 =cut
5529 */
5530
5531 OP *
5532 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5533 {
5534     dVAR;
5535     const bool utf8 = cBOOL(flags & SVf_UTF8);
5536     PVOP *pvop;
5537
5538     flags &= ~SVf_UTF8;
5539
5540     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5541         || type == OP_RUNCV
5542         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5543
5544     NewOp(1101, pvop, 1, PVOP);
5545     pvop->op_type = (OPCODE)type;
5546     pvop->op_ppaddr = PL_ppaddr[type];
5547     pvop->op_pv = pv;
5548     pvop->op_next = (OP*)pvop;
5549     pvop->op_flags = (U8)flags;
5550     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5551     if (PL_opargs[type] & OA_RETSCALAR)
5552         scalar((OP*)pvop);
5553     if (PL_opargs[type] & OA_TARGET)
5554         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5555     return CHECKOP(type, pvop);
5556 }
5557
5558 void
5559 Perl_package(pTHX_ OP *o)
5560 {
5561     SV *const sv = cSVOPo->op_sv;
5562
5563     PERL_ARGS_ASSERT_PACKAGE;
5564
5565     SAVEGENERICSV(PL_curstash);
5566     save_item(PL_curstname);
5567
5568     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5569
5570     sv_setsv(PL_curstname, sv);
5571
5572     PL_hints |= HINT_BLOCK_SCOPE;
5573     PL_parser->copline = NOLINE;
5574
5575     op_free(o);
5576 }
5577
5578 void
5579 Perl_package_version( pTHX_ OP *v )
5580 {
5581     U32 savehints = PL_hints;
5582     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5583     PL_hints &= ~HINT_STRICT_VARS;
5584     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5585     PL_hints = savehints;
5586     op_free(v);
5587 }
5588
5589 void
5590 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5591 {
5592     OP *pack;
5593     OP *imop;
5594     OP *veop;
5595     SV *use_version = NULL;
5596
5597     PERL_ARGS_ASSERT_UTILIZE;
5598
5599     if (idop->op_type != OP_CONST)
5600         Perl_croak(aTHX_ "Module name must be constant");
5601
5602     veop = NULL;
5603
5604     if (version) {
5605         SV * const vesv = ((SVOP*)version)->op_sv;
5606
5607         if (!arg && !SvNIOKp(vesv)) {
5608             arg = version;
5609         }
5610         else {
5611             OP *pack;
5612             SV *meth;
5613
5614             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5615                 Perl_croak(aTHX_ "Version number must be a constant number");
5616
5617             /* Make copy of idop so we don't free it twice */
5618             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5619
5620             /* Fake up a method call to VERSION */
5621             meth = newSVpvs_share("VERSION");
5622             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5623                             op_append_elem(OP_LIST,
5624                                         op_prepend_elem(OP_LIST, pack, version),
5625                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5626         }
5627     }
5628
5629     /* Fake up an import/unimport */
5630     if (arg && arg->op_type == OP_STUB) {
5631         imop = arg;             /* no import on explicit () */
5632     }
5633     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5634         imop = NULL;            /* use 5.0; */
5635         if (aver)
5636             use_version = ((SVOP*)idop)->op_sv;
5637         else
5638             idop->op_private |= OPpCONST_NOVER;
5639     }
5640     else {
5641         SV *meth;
5642
5643         /* Make copy of idop so we don't free it twice */
5644         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5645
5646         /* Fake up a method call to import/unimport */
5647         meth = aver
5648             ? newSVpvs_share("import") : newSVpvs_share("unimport");
5649         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5650                        op_append_elem(OP_LIST,
5651                                    op_prepend_elem(OP_LIST, pack, arg),
5652                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
5653                        ));
5654     }
5655
5656     /* Fake up the BEGIN {}, which does its thing immediately. */
5657     newATTRSUB(floor,
5658         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5659         NULL,
5660         NULL,
5661         op_append_elem(OP_LINESEQ,
5662             op_append_elem(OP_LINESEQ,
5663                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5664                 newSTATEOP(0, NULL, veop)),
5665             newSTATEOP(0, NULL, imop) ));
5666
5667     if (use_version) {
5668         /* Enable the
5669          * feature bundle that corresponds to the required version. */
5670         use_version = sv_2mortal(new_version(use_version));
5671         S_enable_feature_bundle(aTHX_ use_version);
5672
5673         /* If a version >= 5.11.0 is requested, strictures are on by default! */
5674         if (vcmp(use_version,
5675                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5676             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5677                 PL_hints |= HINT_STRICT_REFS;
5678             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5679                 PL_hints |= HINT_STRICT_SUBS;
5680             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5681                 PL_hints |= HINT_STRICT_VARS;
5682         }
5683         /* otherwise they are off */
5684         else {
5685             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5686                 PL_hints &= ~HINT_STRICT_REFS;
5687             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5688                 PL_hints &= ~HINT_STRICT_SUBS;
5689             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5690                 PL_hints &= ~HINT_STRICT_VARS;
5691         }
5692     }
5693
5694     /* The "did you use incorrect case?" warning used to be here.
5695      * The problem is that on case-insensitive filesystems one
5696      * might get false positives for "use" (and "require"):
5697      * "use Strict" or "require CARP" will work.  This causes
5698      * portability problems for the script: in case-strict
5699      * filesystems the script will stop working.
5700      *
5701      * The "incorrect case" warning checked whether "use Foo"
5702      * imported "Foo" to your namespace, but that is wrong, too:
5703      * there is no requirement nor promise in the language that
5704      * a Foo.pm should or would contain anything in package "Foo".
5705      *
5706      * There is very little Configure-wise that can be done, either:
5707      * the case-sensitivity of the build filesystem of Perl does not
5708      * help in guessing the case-sensitivity of the runtime environment.
5709      */
5710
5711     PL_hints |= HINT_BLOCK_SCOPE;
5712     PL_parser->copline = NOLINE;
5713     PL_cop_seqmax++; /* Purely for B::*'s benefit */
5714     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5715         PL_cop_seqmax++;
5716
5717 }
5718
5719 /*
5720 =head1 Embedding Functions
5721
5722 =for apidoc load_module
5723
5724 Loads the module whose name is pointed to by the string part of name.
5725 Note that the actual module name, not its filename, should be given.
5726 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
5727 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5728 (or 0 for no flags).  ver, if specified
5729 and not NULL, provides version semantics
5730 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
5731 arguments can be used to specify arguments to the module's import()
5732 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
5733 terminated with a final NULL pointer.  Note that this list can only
5734 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5735 Otherwise at least a single NULL pointer to designate the default
5736 import list is required.
5737
5738 The reference count for each specified C<SV*> parameter is decremented.
5739
5740 =cut */
5741
5742 void
5743 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5744 {
5745     va_list args;
5746
5747     PERL_ARGS_ASSERT_LOAD_MODULE;
5748
5749     va_start(args, ver);
5750     vload_module(flags, name, ver, &args);
5751     va_end(args);
5752 }
5753
5754 #ifdef PERL_IMPLICIT_CONTEXT
5755 void
5756 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5757 {
5758     dTHX;
5759     va_list args;
5760     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5761     va_start(args, ver);
5762     vload_module(flags, name, ver, &args);
5763     va_end(args);
5764 }
5765 #endif
5766
5767 void
5768 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5769 {
5770     OP *veop, *imop;
5771     OP * const modname = newSVOP(OP_CONST, 0, name);
5772
5773     PERL_ARGS_ASSERT_VLOAD_MODULE;
5774
5775     modname->op_private |= OPpCONST_BARE;
5776     if (ver) {
5777         veop = newSVOP(OP_CONST, 0, ver);
5778     }
5779     else
5780         veop = NULL;
5781     if (flags & PERL_LOADMOD_NOIMPORT) {
5782         imop = sawparens(newNULLLIST());
5783     }
5784     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5785         imop = va_arg(*args, OP*);
5786     }
5787     else {
5788         SV *sv;
5789         imop = NULL;
5790         sv = va_arg(*args, SV*);
5791         while (sv) {
5792             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5793             sv = va_arg(*args, SV*);
5794         }
5795     }
5796
5797     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5798      * that it has a PL_parser to play with while doing that, and also
5799      * that it doesn't mess with any existing parser, by creating a tmp
5800      * new parser with lex_start(). This won't actually be used for much,
5801      * since pp_require() will create another parser for the real work.
5802      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
5803
5804     ENTER;
5805     SAVEVPTR(PL_curcop);
5806     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5807     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5808             veop, modname, imop);
5809     LEAVE;
5810 }
5811
5812 PERL_STATIC_INLINE OP *
5813 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5814 {
5815     return newUNOP(OP_ENTERSUB, OPf_STACKED,
5816                    newLISTOP(OP_LIST, 0, arg,
5817                              newUNOP(OP_RV2CV, 0,
5818                                      newGVOP(OP_GV, 0, gv))));
5819 }
5820
5821 OP *
5822 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5823 {
5824     OP *doop;
5825     GV *gv;
5826
5827     PERL_ARGS_ASSERT_DOFILE;
5828
5829     if (!force_builtin && (gv = gv_override("do", 2))) {
5830         doop = S_new_entersubop(aTHX_ gv, term);
5831     }
5832     else {
5833         doop = newUNOP(OP_DOFILE, 0, scalar(term));
5834     }
5835     return doop;
5836 }
5837
5838 /*
5839 =head1 Optree construction
5840
5841 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5842
5843 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
5844 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5845 be set automatically, and, shifted up eight bits, the eight bits of
5846 C<op_private>, except that the bit with value 1 or 2 is automatically
5847 set as required.  I<listval> and I<subscript> supply the parameters of
5848 the slice; they are consumed by this function and become part of the
5849 constructed op tree.
5850
5851 =cut
5852 */
5853
5854 OP *
5855 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5856 {
5857     return newBINOP(OP_LSLICE, flags,
5858             list(force_list(subscript, 1)),
5859             list(force_list(listval,   1)) );
5860 }
5861
5862 #define ASSIGN_LIST   1
5863 #define ASSIGN_REF    2
5864
5865 STATIC I32
5866 S_assignment_type(pTHX_ const OP *o)
5867 {
5868     unsigned type;
5869     U8 flags;
5870     U8 ret;
5871
5872     if (!o)
5873         return TRUE;
5874
5875     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5876         o = cUNOPo->op_first;
5877
5878     flags = o->op_flags;
5879     type = o->op_type;
5880     if (type == OP_COND_EXPR) {
5881         OP * const sib = OP_SIBLING(cLOGOPo->op_first);
5882         const I32 t = assignment_type(sib);
5883         const I32 f = assignment_type(OP_SIBLING(sib));
5884
5885         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
5886             return ASSIGN_LIST;
5887         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
5888             yyerror("Assignment to both a list and a scalar");
5889         return FALSE;
5890     }
5891
5892     if (type == OP_SREFGEN)
5893     {
5894         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
5895         type = kid->op_type;
5896         flags |= kid->op_flags;
5897         if (!(flags & OPf_PARENS)
5898           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
5899               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
5900             return ASSIGN_REF;
5901         ret = ASSIGN_REF;
5902     }
5903     else ret = 0;
5904
5905     if (type == OP_LIST &&
5906         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5907         o->op_private & OPpLVAL_INTRO)
5908         return ret;
5909
5910     if (type == OP_LIST || flags & OPf_PARENS ||
5911         type == OP_RV2AV || type == OP_RV2HV ||
5912         type == OP_ASLICE || type == OP_HSLICE ||
5913         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
5914         return TRUE;
5915
5916     if (type == OP_PADAV || type == OP_PADHV)
5917         return TRUE;
5918
5919     if (type == OP_RV2SV)
5920         return ret;
5921
5922     return ret;
5923 }
5924
5925 /*
5926   Helper function for newASSIGNOP to detection commonality between the
5927   lhs and the rhs.  (It is actually called very indirectly.  newASSIGNOP
5928   flags the op and the peephole optimizer calls this helper function
5929   if the flag is set.)  Marks all variables with PL_generation.  If it
5930   returns TRUE the assignment must be able to handle common variables.
5931
5932   PL_generation sorcery:
5933   An assignment like ($a,$b) = ($c,$d) is easier than
5934   ($a,$b) = ($c,$a), since there is no need for temporary vars.
5935   To detect whether there are common vars, the global var
5936   PL_generation is incremented for each assign op we compile.
5937   Then, while compiling the assign op, we run through all the
5938   variables on both sides of the assignment, setting a spare slot
5939   in each of them to PL_generation.  If any of them already have
5940   that value, we know we've got commonality.  Also, if the
5941   generation number is already set to PERL_INT_MAX, then
5942   the variable is involved in aliasing, so we also have
5943   potential commonality in that case.  We could use a
5944   single bit marker, but then we'd have to make 2 passes, first
5945   to clear the flag, then to test and set it.  And that
5946   wouldn't help with aliasing, either.  To find somewhere
5947   to store these values, evil chicanery is done with SvUVX().
5948 */
5949 PERL_STATIC_INLINE bool
5950 S_aassign_common_vars(pTHX_ OP* o)
5951 {
5952     OP *curop;
5953     for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
5954         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5955             if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
5956              || curop->op_type == OP_AELEMFAST) {
5957                 GV *gv = cGVOPx_gv(curop);
5958                 if (gv == PL_defgv
5959                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5960                     return TRUE;
5961                 GvASSIGN_GENERATION_set(gv, PL_generation);
5962             }
5963             else if (curop->op_type == OP_PADSV ||
5964                 curop->op_type == OP_PADAV ||
5965                 curop->op_type == OP_PADHV ||
5966                 curop->op_type == OP_AELEMFAST_LEX ||
5967                 curop->op_type == OP_PADANY)
5968                 {
5969                   padcheck:
5970                     if (PAD_COMPNAME_GEN(curop->op_targ)
5971                         == (STRLEN)PL_generation
5972                      || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
5973                         return TRUE;
5974                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5975
5976                 }
5977             else if (curop->op_type == OP_RV2CV)
5978                 return TRUE;
5979             else if (curop->op_type == OP_RV2SV ||
5980                 curop->op_type == OP_RV2AV ||
5981                 curop->op_type == OP_RV2HV ||
5982                 curop->op_type == OP_RV2GV) {
5983                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
5984                     return TRUE;
5985             }
5986             else if (curop->op_type == OP_PUSHRE) {
5987                 GV *const gv =
5988 #ifdef USE_ITHREADS
5989                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5990                         ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5991                         : NULL;
5992 #else
5993                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5994 #endif
5995                 if (gv) {
5996                     if (gv == PL_defgv
5997                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5998                         return TRUE;
5999                     GvASSIGN_GENERATION_set(gv, PL_generation);
6000                 }
6001                 else if (curop->op_targ)
6002                     goto padcheck;
6003             }
6004             else if (curop->op_type == OP_PADRANGE)
6005                 /* Ignore padrange; checking its siblings is sufficient. */
6006                 continue;
6007             else
6008                 return TRUE;
6009         }
6010         else if (PL_opargs[curop->op_type] & OA_TARGLEX
6011               && curop->op_private & OPpTARGET_MY)
6012             goto padcheck;
6013
6014         if (curop->op_flags & OPf_KIDS) {
6015             if (aassign_common_vars(curop))
6016                 return TRUE;
6017         }
6018     }
6019     return FALSE;
6020 }
6021
6022 /* This variant only handles lexical aliases.  It is called when
6023    newASSIGNOP decides that we don’t have any common vars, as lexical ali-
6024    ases trump that decision.  */
6025 PERL_STATIC_INLINE bool
6026 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
6027 {
6028     OP *curop;
6029     for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
6030         if ((curop->op_type == OP_PADSV ||
6031              curop->op_type == OP_PADAV ||
6032              curop->op_type == OP_PADHV ||
6033              curop->op_type == OP_AELEMFAST_LEX ||
6034              curop->op_type == OP_PADANY ||
6035              (  PL_opargs[curop->op_type] & OA_TARGLEX
6036              && curop->op_private & OPpTARGET_MY  ))
6037            && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6038             return TRUE;
6039
6040         if (curop->op_type == OP_PUSHRE && curop->op_targ
6041          && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6042             return TRUE;
6043
6044         if (curop->op_flags & OPf_KIDS) {
6045             if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6046                 return TRUE;
6047         }
6048     }
6049     return FALSE;
6050 }
6051
6052 /*
6053 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6054
6055 Constructs, checks, and returns an assignment op.  I<left> and I<right>
6056 supply the parameters of the assignment; they are consumed by this
6057 function and become part of the constructed op tree.
6058
6059 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6060 a suitable conditional optree is constructed.  If I<optype> is the opcode
6061 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6062 performs the binary operation and assigns the result to the left argument.
6063 Either way, if I<optype> is non-zero then I<flags> has no effect.
6064
6065 If I<optype> is zero, then a plain scalar or list assignment is
6066 constructed.  Which type of assignment it is is automatically determined.
6067 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6068 will be set automatically, and, shifted up eight bits, the eight bits
6069 of C<op_private>, except that the bit with value 1 or 2 is automatically
6070 set as required.
6071
6072 =cut
6073 */
6074
6075 OP *
6076 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6077 {
6078     OP *o;
6079     I32 assign_type;
6080
6081     if (optype) {
6082         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6083             return newLOGOP(optype, 0,
6084                 op_lvalue(scalar(left), optype),
6085                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6086         }
6087         else {
6088             return newBINOP(optype, OPf_STACKED,
6089                 op_lvalue(scalar(left), optype), scalar(right));
6090         }
6091     }
6092
6093     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6094         static const char no_list_state[] = "Initialization of state variables"
6095             " in list context currently forbidden";
6096         OP *curop;
6097         bool maybe_common_vars = TRUE;
6098
6099         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6100             left->op_private &= ~ OPpSLICEWARNING;
6101
6102         PL_modcount = 0;
6103         left = op_lvalue(left, OP_AASSIGN);
6104         curop = list(force_list(left, 1));
6105         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6106         o->op_private = (U8)(0 | (flags >> 8));
6107
6108         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6109         {
6110             OP* lop = ((LISTOP*)left)->op_first;
6111             maybe_common_vars = FALSE;
6112             while (lop) {
6113                 if (lop->op_type == OP_PADSV ||
6114                     lop->op_type == OP_PADAV ||
6115                     lop->op_type == OP_PADHV ||
6116                     lop->op_type == OP_PADANY) {
6117                     if (!(lop->op_private & OPpLVAL_INTRO))
6118                         maybe_common_vars = TRUE;
6119
6120                     if (lop->op_private & OPpPAD_STATE) {
6121                         if (left->op_private & OPpLVAL_INTRO) {
6122                             /* Each variable in state($a, $b, $c) = ... */
6123                         }
6124                         else {
6125                             /* Each state variable in
6126                                (state $a, my $b, our $c, $d, undef) = ... */
6127                         }
6128                         yyerror(no_list_state);
6129                     } else {
6130                         /* Each my variable in
6131                            (state $a, my $b, our $c, $d, undef) = ... */
6132                     }
6133                 } else if (lop->op_type == OP_UNDEF ||
6134                            OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6135                     /* undef may be interesting in
6136                        (state $a, undef, state $c) */
6137                 } else {
6138                     /* Other ops in the list. */
6139                     maybe_common_vars = TRUE;
6140                 }
6141                 lop = OP_SIBLING(lop);
6142             }
6143         }
6144         else if ((left->op_private & OPpLVAL_INTRO)
6145                 && (   left->op_type == OP_PADSV
6146                     || left->op_type == OP_PADAV
6147                     || left->op_type == OP_PADHV
6148                     || left->op_type == OP_PADANY))
6149         {
6150             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6151             if (left->op_private & OPpPAD_STATE) {
6152                 /* All single variable list context state assignments, hence
6153                    state ($a) = ...
6154                    (state $a) = ...
6155                    state @a = ...
6156                    state (@a) = ...
6157                    (state @a) = ...
6158                    state %a = ...
6159                    state (%a) = ...
6160                    (state %a) = ...
6161                 */
6162                 yyerror(no_list_state);
6163             }
6164         }
6165
6166         if (maybe_common_vars) {
6167                 /* The peephole optimizer will do the full check and pos-
6168                    sibly turn this off.  */
6169                 o->op_private |= OPpASSIGN_COMMON;
6170         }
6171
6172         if (right && right->op_type == OP_SPLIT
6173          && !(right->op_flags & OPf_STACKED)) {
6174             OP* tmpop = ((LISTOP*)right)->op_first;
6175             PMOP * const pm = (PMOP*)tmpop;
6176             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6177             if (
6178 #ifdef USE_ITHREADS
6179                     !pm->op_pmreplrootu.op_pmtargetoff
6180 #else
6181                     !pm->op_pmreplrootu.op_pmtargetgv
6182 #endif
6183                  && !pm->op_targ
6184                 ) {
6185                     if (!(left->op_private & OPpLVAL_INTRO) &&
6186                         ( (left->op_type == OP_RV2AV &&
6187                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6188                         || left->op_type == OP_PADAV )
6189                         ) {
6190                         if (tmpop != (OP *)pm) {
6191 #ifdef USE_ITHREADS
6192                           pm->op_pmreplrootu.op_pmtargetoff
6193                             = cPADOPx(tmpop)->op_padix;
6194                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6195 #else
6196                           pm->op_pmreplrootu.op_pmtargetgv
6197                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6198                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6199 #endif
6200                           right->op_private |=
6201                             left->op_private & OPpOUR_INTRO;
6202                         }
6203                         else {
6204                             pm->op_targ = left->op_targ;
6205                             left->op_targ = 0; /* filch it */
6206                         }
6207                       detach_split:
6208                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6209                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6210                         /* detach rest of siblings from o subtree,
6211                          * and free subtree */
6212                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6213                         op_free(o);                     /* blow off assign */
6214                         right->op_flags &= ~OPf_WANT;
6215                                 /* "I don't know and I don't care." */
6216                         return right;
6217                     }
6218                     else if (left->op_type == OP_RV2AV
6219                           || left->op_type == OP_PADAV)
6220                     {
6221                         /* Detach the array.  */
6222 #ifdef DEBUGGING
6223                         OP * const ary =
6224 #endif
6225                         op_sibling_splice(cBINOPo->op_last,
6226                                           cUNOPx(cBINOPo->op_last)
6227                                                 ->op_first, 1, NULL);
6228                         assert(ary == left);
6229                         /* Attach it to the split.  */
6230                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6231                                           0, left);
6232                         right->op_flags |= OPf_STACKED;
6233                         /* Detach split and expunge aassign as above.  */
6234                         goto detach_split;
6235                     }
6236                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6237                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6238                     {
6239                         SV ** const svp =
6240                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6241                         SV * const sv = *svp;
6242                         if (SvIOK(sv) && SvIVX(sv) == 0)
6243                         {
6244                           if (right->op_private & OPpSPLIT_IMPLIM) {
6245                             /* our own SV, created in ck_split */
6246                             SvREADONLY_off(sv);
6247                             sv_setiv(sv, PL_modcount+1);
6248                           }
6249                           else {
6250                             /* SV may belong to someone else */
6251                             SvREFCNT_dec(sv);
6252                             *svp = newSViv(PL_modcount+1);
6253                           }
6254                         }
6255                     }
6256             }
6257         }
6258         return o;
6259     }
6260     if (assign_type == ASSIGN_REF)
6261         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6262     if (!right)
6263         right = newOP(OP_UNDEF, 0);
6264     if (right->op_type == OP_READLINE) {
6265         right->op_flags |= OPf_STACKED;
6266         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6267                 scalar(right));
6268     }
6269     else {
6270         o = newBINOP(OP_SASSIGN, flags,
6271             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6272     }
6273     return o;
6274 }
6275
6276 /*
6277 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6278
6279 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6280 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6281 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6282 If I<label> is non-null, it supplies the name of a label to attach to
6283 the state op; this function takes ownership of the memory pointed at by
6284 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
6285 for the state op.
6286
6287 If I<o> is null, the state op is returned.  Otherwise the state op is
6288 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
6289 is consumed by this function and becomes part of the returned op tree.
6290
6291 =cut
6292 */
6293
6294 OP *
6295 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6296 {
6297     dVAR;
6298     const U32 seq = intro_my();
6299     const U32 utf8 = flags & SVf_UTF8;
6300     COP *cop;
6301
6302     flags &= ~SVf_UTF8;
6303
6304     NewOp(1101, cop, 1, COP);
6305     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6306         cop->op_type = OP_DBSTATE;
6307         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
6308     }
6309     else {
6310         cop->op_type = OP_NEXTSTATE;
6311         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
6312     }
6313     cop->op_flags = (U8)flags;
6314     CopHINTS_set(cop, PL_hints);
6315 #ifdef NATIVE_HINTS
6316     cop->op_private |= NATIVE_HINTS;
6317 #endif
6318 #ifdef VMS
6319     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6320 #endif
6321     cop->op_next = (OP*)cop;
6322
6323     cop->cop_seq = seq;
6324     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6325     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6326     if (label) {
6327         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6328
6329         PL_hints |= HINT_BLOCK_SCOPE;
6330         /* It seems that we need to defer freeing this pointer, as other parts
6331            of the grammar end up wanting to copy it after this op has been
6332            created. */
6333         SAVEFREEPV(label);
6334     }
6335
6336     if (PL_parser->preambling != NOLINE) {
6337         CopLINE_set(cop, PL_parser->preambling);
6338         PL_parser->copline = NOLINE;
6339     }
6340     else if (PL_parser->copline == NOLINE)
6341         CopLINE_set(cop, CopLINE(PL_curcop));
6342     else {
6343         CopLINE_set(cop, PL_parser->copline);
6344         PL_parser->copline = NOLINE;
6345     }
6346 #ifdef USE_ITHREADS
6347     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6348 #else
6349     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6350 #endif
6351     CopSTASH_set(cop, PL_curstash);
6352
6353     if (cop->op_type == OP_DBSTATE) {
6354         /* this line can have a breakpoint - store the cop in IV */
6355         AV *av = CopFILEAVx(PL_curcop);
6356         if (av) {
6357             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6358             if (svp && *svp != &PL_sv_undef ) {
6359                 (void)SvIOK_on(*svp);
6360                 SvIV_set(*svp, PTR2IV(cop));
6361             }
6362         }
6363     }
6364
6365     if (flags & OPf_SPECIAL)
6366         op_null((OP*)cop);
6367     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6368 }
6369
6370 /*
6371 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6372
6373 Constructs, checks, and returns a logical (flow control) op.  I<type>
6374 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
6375 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6376 the eight bits of C<op_private>, except that the bit with value 1 is
6377 automatically set.  I<first> supplies the expression controlling the
6378 flow, and I<other> supplies the side (alternate) chain of ops; they are
6379 consumed by this function and become part of the constructed op tree.
6380
6381 =cut
6382 */
6383
6384 OP *
6385 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6386 {
6387     PERL_ARGS_ASSERT_NEWLOGOP;
6388
6389     return new_logop(type, flags, &first, &other);
6390 }
6391
6392 STATIC OP *
6393 S_search_const(pTHX_ OP *o)
6394 {
6395     PERL_ARGS_ASSERT_SEARCH_CONST;
6396
6397     switch (o->op_type) {
6398         case OP_CONST:
6399             return o;
6400         case OP_NULL:
6401             if (o->op_flags & OPf_KIDS)
6402                 return search_const(cUNOPo->op_first);
6403             break;
6404         case OP_LEAVE:
6405         case OP_SCOPE:
6406         case OP_LINESEQ:
6407         {
6408             OP *kid;
6409             if (!(o->op_flags & OPf_KIDS))
6410                 return NULL;
6411             kid = cLISTOPo->op_first;
6412             do {
6413                 switch (kid->op_type) {
6414                     case OP_ENTER:
6415                     case OP_NULL:
6416                     case OP_NEXTSTATE:
6417                         kid = OP_SIBLING(kid);
6418                         break;
6419                     default:
6420                         if (kid != cLISTOPo->op_last)
6421                             return NULL;
6422                         goto last;
6423                 }
6424             } while (kid);
6425             if (!kid)
6426                 kid = cLISTOPo->op_last;
6427 last:
6428             return search_const(kid);
6429         }
6430     }
6431
6432     return NULL;
6433 }
6434
6435 STATIC OP *
6436 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6437 {
6438     dVAR;
6439     LOGOP *logop;
6440     OP *o;
6441     OP *first;
6442     OP *other;
6443     OP *cstop = NULL;
6444     int prepend_not = 0;
6445
6446     PERL_ARGS_ASSERT_NEW_LOGOP;
6447
6448     first = *firstp;
6449     other = *otherp;
6450
6451     /* [perl #59802]: Warn about things like "return $a or $b", which
6452        is parsed as "(return $a) or $b" rather than "return ($a or
6453        $b)".  NB: This also applies to xor, which is why we do it
6454        here.
6455      */
6456     switch (first->op_type) {
6457     case OP_NEXT:
6458     case OP_LAST:
6459     case OP_REDO:
6460         /* XXX: Perhaps we should emit a stronger warning for these.
6461            Even with the high-precedence operator they don't seem to do
6462            anything sensible.
6463
6464            But until we do, fall through here.
6465          */
6466     case OP_RETURN:
6467     case OP_EXIT:
6468     case OP_DIE:
6469     case OP_GOTO:
6470         /* XXX: Currently we allow people to "shoot themselves in the
6471            foot" by explicitly writing "(return $a) or $b".
6472
6473            Warn unless we are looking at the result from folding or if
6474            the programmer explicitly grouped the operators like this.
6475            The former can occur with e.g.
6476
6477                 use constant FEATURE => ( $] >= ... );
6478                 sub { not FEATURE and return or do_stuff(); }
6479          */
6480         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6481             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6482                            "Possible precedence issue with control flow operator");
6483         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6484            the "or $b" part)?
6485         */
6486         break;
6487     }
6488
6489     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6490         return newBINOP(type, flags, scalar(first), scalar(other));
6491
6492     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6493
6494     scalarboolean(first);
6495     /* optimize AND and OR ops that have NOTs as children */
6496     if (first->op_type == OP_NOT
6497         && (first->op_flags & OPf_KIDS)
6498         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6499             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6500         ) {
6501         if (type == OP_AND || type == OP_OR) {
6502             if (type == OP_AND)
6503                 type = OP_OR;
6504             else
6505                 type = OP_AND;
6506             op_null(first);
6507             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6508                 op_null(other);
6509                 prepend_not = 1; /* prepend a NOT op later */
6510             }
6511         }
6512     }
6513     /* search for a constant op that could let us fold the test */
6514     if ((cstop = search_const(first))) {
6515         if (cstop->op_private & OPpCONST_STRICT)
6516             no_bareword_allowed(cstop);
6517         else if ((cstop->op_private & OPpCONST_BARE))
6518                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6519         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6520             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6521             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6522             *firstp = NULL;
6523             if (other->op_type == OP_CONST)
6524                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6525             op_free(first);
6526             if (other->op_type == OP_LEAVE)
6527                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6528             else if (other->op_type == OP_MATCH
6529                   || other->op_type == OP_SUBST
6530                   || other->op_type == OP_TRANSR
6531                   || other->op_type == OP_TRANS)
6532                 /* Mark the op as being unbindable with =~ */
6533                 other->op_flags |= OPf_SPECIAL;
6534
6535             other->op_folded = 1;
6536             return other;
6537         }
6538         else {
6539             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6540             const OP *o2 = other;
6541             if ( ! (o2->op_type == OP_LIST
6542                     && (( o2 = cUNOPx(o2)->op_first))
6543                     && o2->op_type == OP_PUSHMARK
6544                     && (( o2 = OP_SIBLING(o2))) )
6545             )
6546                 o2 = other;
6547             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6548                         || o2->op_type == OP_PADHV)
6549                 && o2->op_private & OPpLVAL_INTRO
6550                 && !(o2->op_private & OPpPAD_STATE))
6551             {
6552                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6553                                  "Deprecated use of my() in false conditional");
6554             }
6555
6556             *otherp = NULL;
6557             if (cstop->op_type == OP_CONST)
6558                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6559                 op_free(other);
6560             return first;
6561         }
6562     }
6563     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6564         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6565     {
6566         const OP * const k1 = ((UNOP*)first)->op_first;
6567         const OP * const k2 = OP_SIBLING(k1);
6568         OPCODE warnop = 0;
6569         switch (first->op_type)
6570         {
6571         case OP_NULL:
6572             if (k2 && k2->op_type == OP_READLINE
6573                   && (k2->op_flags & OPf_STACKED)
6574                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6575             {
6576                 warnop = k2->op_type;
6577             }
6578             break;
6579
6580         case OP_SASSIGN:
6581             if (k1->op_type == OP_READDIR
6582                   || k1->op_type == OP_GLOB
6583                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6584                  || k1->op_type == OP_EACH
6585                  || k1->op_type == OP_AEACH)
6586             {
6587                 warnop = ((k1->op_type == OP_NULL)
6588                           ? (OPCODE)k1->op_targ : k1->op_type);
6589             }
6590             break;
6591         }
6592         if (warnop) {
6593             const line_t oldline = CopLINE(PL_curcop);
6594             /* This ensures that warnings are reported at the first line
6595                of the construction, not the last.  */
6596             CopLINE_set(PL_curcop, PL_parser->copline);
6597             Perl_warner(aTHX_ packWARN(WARN_MISC),
6598                  "Value of %s%s can be \"0\"; test with defined()",
6599                  PL_op_desc[warnop],
6600                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6601                   ? " construct" : "() operator"));
6602             CopLINE_set(PL_curcop, oldline);
6603         }
6604     }
6605
6606     if (!other)
6607         return first;
6608
6609     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6610         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6611
6612     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6613     logop->op_ppaddr = PL_ppaddr[type];
6614     logop->op_flags |= (U8)flags;
6615     logop->op_private = (U8)(1 | (flags >> 8));
6616
6617     /* establish postfix order */
6618     logop->op_next = LINKLIST(first);
6619     first->op_next = (OP*)logop;
6620     assert(!OP_HAS_SIBLING(first));
6621     op_sibling_splice((OP*)logop, first, 0, other);
6622
6623     CHECKOP(type,logop);
6624
6625     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6626     other->op_next = o;
6627
6628     return o;
6629 }
6630
6631 /*
6632 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6633
6634 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6635 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6636 will be set automatically, and, shifted up eight bits, the eight bits of
6637 C<op_private>, except that the bit with value 1 is automatically set.
6638 I<first> supplies the expression selecting between the two branches,
6639 and I<trueop> and I<falseop> supply the branches; they are consumed by
6640 this function and become part of the constructed op tree.
6641
6642 =cut
6643 */
6644
6645 OP *
6646 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6647 {
6648     dVAR;
6649     LOGOP *logop;
6650     OP *start;
6651     OP *o;
6652     OP *cstop;
6653
6654     PERL_ARGS_ASSERT_NEWCONDOP;
6655
6656     if (!falseop)
6657         return newLOGOP(OP_AND, 0, first, trueop);
6658     if (!trueop)
6659         return newLOGOP(OP_OR, 0, first, falseop);
6660
6661     scalarboolean(first);
6662     if ((cstop = search_const(first))) {
6663         /* Left or right arm of the conditional?  */
6664         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6665         OP *live = left ? trueop : falseop;
6666         OP *const dead = left ? falseop : trueop;
6667         if (cstop->op_private & OPpCONST_BARE &&
6668             cstop->op_private & OPpCONST_STRICT) {
6669             no_bareword_allowed(cstop);
6670         }
6671         op_free(first);
6672         op_free(dead);
6673         if (live->op_type == OP_LEAVE)
6674             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6675     &nb