6ac8f3fa30acd3f9555a28226ce29392657dd12b
[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         ) {
1898             op_null(cUNOPo->op_first); /* NULL the pushmark */
1899             op_null(o); /* NULL the list */
1900         }
1901         goto kids;
1902     case OP_ENTEREVAL:
1903         scalarkids(o);
1904         break;
1905     case OP_SCALAR:
1906         return scalar(o);
1907     }
1908
1909     if (useless_sv) {
1910         /* mortalise it, in case warnings are fatal.  */
1911         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1912                        "Useless use of %"SVf" in void context",
1913                        SVfARG(sv_2mortal(useless_sv)));
1914     }
1915     else if (useless) {
1916        Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1917                       "Useless use of %s in void context",
1918                       useless);
1919     }
1920     return o;
1921 }
1922
1923 static OP *
1924 S_listkids(pTHX_ OP *o)
1925 {
1926     if (o && o->op_flags & OPf_KIDS) {
1927         OP *kid;
1928         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
1929             list(kid);
1930     }
1931     return o;
1932 }
1933
1934 OP *
1935 Perl_list(pTHX_ OP *o)
1936 {
1937     OP *kid;
1938
1939     /* assumes no premature commitment */
1940     if (!o || (o->op_flags & OPf_WANT)
1941          || (PL_parser && PL_parser->error_count)
1942          || o->op_type == OP_RETURN)
1943     {
1944         return o;
1945     }
1946
1947     if ((o->op_private & OPpTARGET_MY)
1948         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1949     {
1950         return o;                               /* As if inside SASSIGN */
1951     }
1952
1953     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1954
1955     switch (o->op_type) {
1956     case OP_FLOP:
1957     case OP_REPEAT:
1958         list(cBINOPo->op_first);
1959         break;
1960     case OP_OR:
1961     case OP_AND:
1962     case OP_COND_EXPR:
1963         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
1964             list(kid);
1965         break;
1966     default:
1967     case OP_MATCH:
1968     case OP_QR:
1969     case OP_SUBST:
1970     case OP_NULL:
1971         if (!(o->op_flags & OPf_KIDS))
1972             break;
1973         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1974             list(cBINOPo->op_first);
1975             return gen_constant_list(o);
1976         }
1977         listkids(o);
1978         break;
1979     case OP_LIST:
1980         listkids(o);
1981         if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
1982             op_null(cUNOPo->op_first); /* NULL the pushmark */
1983             op_null(o); /* NULL the list */
1984         }
1985         break;
1986     case OP_LEAVE:
1987     case OP_LEAVETRY:
1988         kid = cLISTOPo->op_first;
1989         list(kid);
1990         kid = OP_SIBLING(kid);
1991     do_kids:
1992         while (kid) {
1993             OP *sib = OP_SIBLING(kid);
1994             if (sib && kid->op_type != OP_LEAVEWHEN)
1995                 scalarvoid(kid);
1996             else
1997                 list(kid);
1998             kid = sib;
1999         }
2000         PL_curcop = &PL_compiling;
2001         break;
2002     case OP_SCOPE:
2003     case OP_LINESEQ:
2004         kid = cLISTOPo->op_first;
2005         goto do_kids;
2006     }
2007     return o;
2008 }
2009
2010 static OP *
2011 S_scalarseq(pTHX_ OP *o)
2012 {
2013     if (o) {
2014         const OPCODE type = o->op_type;
2015
2016         if (type == OP_LINESEQ || type == OP_SCOPE ||
2017             type == OP_LEAVE || type == OP_LEAVETRY)
2018         {
2019             OP *kid;
2020             for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2021                 if (OP_HAS_SIBLING(kid)) {
2022                     scalarvoid(kid);
2023                 }
2024             }
2025             PL_curcop = &PL_compiling;
2026         }
2027         o->op_flags &= ~OPf_PARENS;
2028         if (PL_hints & HINT_BLOCK_SCOPE)
2029             o->op_flags |= OPf_PARENS;
2030     }
2031     else
2032         o = newOP(OP_STUB, 0);
2033     return o;
2034 }
2035
2036 STATIC OP *
2037 S_modkids(pTHX_ OP *o, I32 type)
2038 {
2039     if (o && o->op_flags & OPf_KIDS) {
2040         OP *kid;
2041         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2042             op_lvalue(kid, type);
2043     }
2044     return o;
2045 }
2046
2047 /*
2048 =for apidoc finalize_optree
2049
2050 This function finalizes the optree.  Should be called directly after
2051 the complete optree is built.  It does some additional
2052 checking which can't be done in the normal ck_xxx functions and makes
2053 the tree thread-safe.
2054
2055 =cut
2056 */
2057 void
2058 Perl_finalize_optree(pTHX_ OP* o)
2059 {
2060     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
2061
2062     ENTER;
2063     SAVEVPTR(PL_curcop);
2064
2065     finalize_op(o);
2066
2067     LEAVE;
2068 }
2069
2070 #ifdef USE_ITHREADS
2071 /* Relocate sv to the pad for thread safety.
2072  * Despite being a "constant", the SV is written to,
2073  * for reference counts, sv_upgrade() etc. */
2074 PERL_STATIC_INLINE void
2075 S_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2076 {
2077     PADOFFSET ix;
2078     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2079     if (!*svp) return;
2080     ix = pad_alloc(OP_CONST, SVf_READONLY);
2081     SvREFCNT_dec(PAD_SVl(ix));
2082     PAD_SETSV(ix, *svp);
2083     /* XXX I don't know how this isn't readonly already. */
2084     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2085     *svp = NULL;
2086     *targp = ix;
2087 }
2088 #endif
2089
2090
2091 STATIC void
2092 S_finalize_op(pTHX_ OP* o)
2093 {
2094     PERL_ARGS_ASSERT_FINALIZE_OP;
2095
2096
2097     switch (o->op_type) {
2098     case OP_NEXTSTATE:
2099     case OP_DBSTATE:
2100         PL_curcop = ((COP*)o);          /* for warnings */
2101         break;
2102     case OP_EXEC:
2103         if (OP_HAS_SIBLING(o)) {
2104             OP *sib = OP_SIBLING(o);
2105             if ((  sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
2106                 && ckWARN(WARN_EXEC)
2107                 && OP_HAS_SIBLING(sib))
2108             {
2109                     const OPCODE type = OP_SIBLING(sib)->op_type;
2110                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
2111                         const line_t oldline = CopLINE(PL_curcop);
2112                         CopLINE_set(PL_curcop, CopLINE((COP*)sib));
2113                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2114                             "Statement unlikely to be reached");
2115                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
2116                             "\t(Maybe you meant system() when you said exec()?)\n");
2117                         CopLINE_set(PL_curcop, oldline);
2118                     }
2119             }
2120         }
2121         break;
2122
2123     case OP_GV:
2124         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
2125             GV * const gv = cGVOPo_gv;
2126             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
2127                 /* XXX could check prototype here instead of just carping */
2128                 SV * const sv = sv_newmortal();
2129                 gv_efullname3(sv, gv, NULL);
2130                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2131                     "%"SVf"() called too early to check prototype",
2132                     SVfARG(sv));
2133             }
2134         }
2135         break;
2136
2137     case OP_CONST:
2138         if (cSVOPo->op_private & OPpCONST_STRICT)
2139             no_bareword_allowed(o);
2140         /* FALLTHROUGH */
2141 #ifdef USE_ITHREADS
2142     case OP_HINTSEVAL:
2143         op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
2144 #endif
2145         break;
2146
2147 #ifdef USE_ITHREADS
2148     /* Relocate all the METHOP's SVs to the pad for thread safety. */
2149     case OP_METHOD_NAMED:
2150         op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
2151         break;
2152 #endif
2153
2154     case OP_HELEM: {
2155         UNOP *rop;
2156         SV *lexname;
2157         GV **fields;
2158         SVOP *key_op;
2159         OP *kid;
2160         bool check_fields;
2161
2162         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
2163             break;
2164
2165         rop = (UNOP*)((BINOP*)o)->op_first;
2166
2167         goto check_keys;
2168
2169     case OP_HSLICE:
2170         S_scalar_slice_warning(aTHX_ o);
2171         /* FALLTHROUGH */
2172
2173     case OP_KVHSLICE:
2174         kid = OP_SIBLING(cLISTOPo->op_first);
2175         if (/* I bet there's always a pushmark... */
2176             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
2177             && OP_TYPE_ISNT_NN(kid, OP_CONST))
2178         {
2179             break;
2180         }
2181
2182         key_op = (SVOP*)(kid->op_type == OP_CONST
2183                                 ? kid
2184                                 : OP_SIBLING(kLISTOP->op_first));
2185
2186         rop = (UNOP*)((LISTOP*)o)->op_last;
2187
2188       check_keys:       
2189         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
2190             rop = NULL;
2191         else if (rop->op_first->op_type == OP_PADSV)
2192             /* @$hash{qw(keys here)} */
2193             rop = (UNOP*)rop->op_first;
2194         else {
2195             /* @{$hash}{qw(keys here)} */
2196             if (rop->op_first->op_type == OP_SCOPE
2197                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2198                 {
2199                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2200                 }
2201             else
2202                 rop = NULL;
2203         }
2204
2205         lexname = NULL; /* just to silence compiler warnings */
2206         fields  = NULL; /* just to silence compiler warnings */
2207
2208         check_fields =
2209             rop
2210          && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2211              SvPAD_TYPED(lexname))
2212          && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2213          && isGV(*fields) && GvHV(*fields);
2214         for (; key_op;
2215              key_op = (SVOP*)OP_SIBLING(key_op)) {
2216             SV **svp, *sv;
2217             if (key_op->op_type != OP_CONST)
2218                 continue;
2219             svp = cSVOPx_svp(key_op);
2220
2221             /* Make the CONST have a shared SV */
2222             if ((!SvIsCOW_shared_hash(sv = *svp))
2223              && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2224                 SSize_t keylen;
2225                 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2226                 SV *nsv = newSVpvn_share(key,
2227                                          SvUTF8(sv) ? -keylen : keylen, 0);
2228                 SvREFCNT_dec_NN(sv);
2229                 *svp = nsv;
2230             }
2231
2232             if (check_fields
2233              && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2234                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" " 
2235                            "in variable %"SVf" of type %"HEKf, 
2236                       SVfARG(*svp), SVfARG(lexname),
2237                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2238             }
2239         }
2240         break;
2241     }
2242     case OP_ASLICE:
2243         S_scalar_slice_warning(aTHX_ o);
2244         break;
2245
2246     case OP_SUBST: {
2247         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2248             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2249         break;
2250     }
2251     default:
2252         break;
2253     }
2254
2255     if (o->op_flags & OPf_KIDS) {
2256         OP *kid;
2257
2258 #ifdef DEBUGGING
2259         /* check that op_last points to the last sibling, and that
2260          * the last op_sibling field points back to the parent, and
2261          * that the only ops with KIDS are those which are entitled to
2262          * them */
2263         U32 type = o->op_type;
2264         U32 family;
2265         bool has_last;
2266
2267         if (type == OP_NULL) {
2268             type = o->op_targ;
2269             /* ck_glob creates a null UNOP with ex-type GLOB
2270              * (which is a list op. So pretend it wasn't a listop */
2271             if (type == OP_GLOB)
2272                 type = OP_NULL;
2273         }
2274         family = PL_opargs[type] & OA_CLASS_MASK;
2275
2276         has_last = (   family == OA_BINOP
2277                     || family == OA_LISTOP
2278                     || family == OA_PMOP
2279                     || family == OA_LOOP
2280                    );
2281         assert(  has_last /* has op_first and op_last, or ...
2282               ... has (or may have) op_first: */
2283               || family == OA_UNOP
2284               || family == OA_LOGOP
2285               || family == OA_BASEOP_OR_UNOP
2286               || family == OA_FILESTATOP
2287               || family == OA_LOOPEXOP
2288               || family == OA_METHOP
2289               /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */
2290               || type == OP_SASSIGN
2291               || type == OP_CUSTOM
2292               || type == OP_NULL /* new_logop does this */
2293               );
2294         /* XXX list form of 'x' is has a null op_last. This is wrong,
2295          * but requires too much hacking (e.g. in Deparse) to fix for
2296          * now */
2297         if (type == OP_REPEAT && (o->op_private & OPpREPEAT_DOLIST)) {
2298             assert(has_last);
2299             has_last = 0;
2300         }
2301
2302         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2303 #  ifdef PERL_OP_PARENT
2304             if (!OP_HAS_SIBLING(kid)) {
2305                 if (has_last)
2306                     assert(kid == cLISTOPo->op_last);
2307                 assert(kid->op_sibling == o);
2308             }
2309 #  else
2310             if (OP_HAS_SIBLING(kid)) {
2311                 assert(!kid->op_lastsib);
2312             }
2313             else {
2314                 assert(kid->op_lastsib);
2315                 if (has_last)
2316                     assert(kid == cLISTOPo->op_last);
2317             }
2318 #  endif
2319         }
2320 #endif
2321
2322         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
2323             finalize_op(kid);
2324     }
2325 }
2326
2327 /*
2328 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2329
2330 Propagate lvalue ("modifiable") context to an op and its children.
2331 I<type> represents the context type, roughly based on the type of op that
2332 would do the modifying, although C<local()> is represented by OP_NULL,
2333 because it has no op type of its own (it is signalled by a flag on
2334 the lvalue op).
2335
2336 This function detects things that can't be modified, such as C<$x+1>, and
2337 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2338 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2339
2340 It also flags things that need to behave specially in an lvalue context,
2341 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2342
2343 =cut
2344 */
2345
2346 static bool
2347 S_vivifies(const OPCODE type)
2348 {
2349     switch(type) {
2350     case OP_RV2AV:     case   OP_ASLICE:
2351     case OP_RV2HV:     case OP_KVASLICE:
2352     case OP_RV2SV:     case   OP_HSLICE:
2353     case OP_AELEMFAST: case OP_KVHSLICE:
2354     case OP_HELEM:
2355     case OP_AELEM:
2356         return 1;
2357     }
2358     return 0;
2359 }
2360
2361 static void
2362 S_lvref(pTHX_ OP *o, I32 type)
2363 {
2364     dVAR;
2365     OP *kid;
2366     switch (o->op_type) {
2367     case OP_COND_EXPR:
2368         for (kid = OP_SIBLING(cUNOPo->op_first); kid;
2369              kid = OP_SIBLING(kid))
2370             S_lvref(aTHX_ kid, type);
2371         /* FALLTHROUGH */
2372     case OP_PUSHMARK:
2373         return;
2374     case OP_RV2AV:
2375         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2376         o->op_flags |= OPf_STACKED;
2377         if (o->op_flags & OPf_PARENS) {
2378             if (o->op_private & OPpLVAL_INTRO) {
2379                  yyerror(Perl_form(aTHX_ "Can't modify reference to "
2380                       "localized parenthesized array in list assignment"));
2381                 return;
2382             }
2383           slurpy:
2384             o->op_type = OP_LVAVREF;
2385             o->op_ppaddr = PL_ppaddr[OP_LVAVREF];
2386             o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2387             o->op_flags |= OPf_MOD|OPf_REF;
2388             return;
2389         }
2390         o->op_private |= OPpLVREF_AV;
2391         goto checkgv;
2392     case OP_RV2CV:
2393         kid = cUNOPo->op_first;
2394         if (kid->op_type == OP_NULL)
2395             kid = cUNOPx(kUNOP->op_first->op_sibling)
2396                 ->op_first;
2397         o->op_private = OPpLVREF_CV;
2398         if (kid->op_type == OP_GV)
2399             o->op_flags |= OPf_STACKED;
2400         else if (kid->op_type == OP_PADCV) {
2401             o->op_targ = kid->op_targ;
2402             kid->op_targ = 0;
2403             op_free(cUNOPo->op_first);
2404             cUNOPo->op_first = NULL;
2405             o->op_flags &=~ OPf_KIDS;
2406         }
2407         else goto badref;
2408         break;
2409     case OP_RV2HV:
2410         if (o->op_flags & OPf_PARENS) {
2411           parenhash:
2412             yyerror(Perl_form(aTHX_ "Can't modify reference to "
2413                                  "parenthesized hash in list assignment"));
2414                 return;
2415         }
2416         o->op_private |= OPpLVREF_HV;
2417         /* FALLTHROUGH */
2418     case OP_RV2SV:
2419       checkgv:
2420         if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2421         o->op_flags |= OPf_STACKED;
2422         break;
2423     case OP_PADHV:
2424         if (o->op_flags & OPf_PARENS) goto parenhash;
2425         o->op_private |= OPpLVREF_HV;
2426         /* FALLTHROUGH */
2427     case OP_PADSV:
2428         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2429         break;
2430     case OP_PADAV:
2431         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2432         if (o->op_flags & OPf_PARENS) goto slurpy;
2433         o->op_private |= OPpLVREF_AV;
2434         break;
2435     case OP_AELEM:
2436     case OP_HELEM:
2437         o->op_private |= OPpLVREF_ELEM;
2438         o->op_flags   |= OPf_STACKED;
2439         break;
2440     case OP_ASLICE:
2441     case OP_HSLICE:
2442         o->op_type = OP_LVREFSLICE;
2443         o->op_ppaddr = PL_ppaddr[OP_LVREFSLICE];
2444         o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
2445         return;
2446     case OP_NULL:
2447         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2448             goto badref;
2449         else if (!(o->op_flags & OPf_KIDS))
2450             return;
2451         if (o->op_targ != OP_LIST) {
2452             S_lvref(aTHX_ cBINOPo->op_first, type);
2453             return;
2454         }
2455         /* FALLTHROUGH */
2456     case OP_LIST:
2457         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
2458             assert((kid->op_flags & OPf_WANT) != OPf_WANT_VOID);
2459             S_lvref(aTHX_ kid, type);
2460         }
2461         return;
2462     case OP_STUB:
2463         if (o->op_flags & OPf_PARENS)
2464             return;
2465         /* FALLTHROUGH */
2466     default:
2467       badref:
2468         /* diag_listed_as: Can't modify reference to %s in %s assignment */
2469         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2470                      o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2471                       ? "do block"
2472                       : OP_DESC(o),
2473                      PL_op_desc[type]));
2474         return;
2475     }
2476     o->op_type = OP_LVREF;
2477     o->op_ppaddr = PL_ppaddr[OP_LVREF];
2478     o->op_private &=
2479         OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2480     if (type == OP_ENTERLOOP)
2481         o->op_private |= OPpLVREF_ITER;
2482 }
2483
2484 OP *
2485 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2486 {
2487     dVAR;
2488     OP *kid;
2489     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2490     int localize = -1;
2491
2492     if (!o || (PL_parser && PL_parser->error_count))
2493         return o;
2494
2495     if ((o->op_private & OPpTARGET_MY)
2496         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2497     {
2498         return o;
2499     }
2500
2501     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2502
2503     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2504
2505     switch (o->op_type) {
2506     case OP_UNDEF:
2507         PL_modcount++;
2508         return o;
2509     case OP_STUB:
2510         if ((o->op_flags & OPf_PARENS))
2511             break;
2512         goto nomod;
2513     case OP_ENTERSUB:
2514         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2515             !(o->op_flags & OPf_STACKED)) {
2516             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
2517             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2518             assert(cUNOPo->op_first->op_type == OP_NULL);
2519             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2520             break;
2521         }
2522         else {                          /* lvalue subroutine call */
2523             o->op_private |= OPpLVAL_INTRO;
2524             PL_modcount = RETURN_UNLIMITED_NUMBER;
2525             if (type == OP_GREPSTART || type == OP_ENTERSUB
2526              || type == OP_REFGEN    || type == OP_LEAVESUBLV) {
2527                 /* Potential lvalue context: */
2528                 o->op_private |= OPpENTERSUB_INARGS;
2529                 break;
2530             }
2531             else {                      /* Compile-time error message: */
2532                 OP *kid = cUNOPo->op_first;
2533                 CV *cv;
2534                 GV *gv;
2535
2536                 if (kid->op_type != OP_PUSHMARK) {
2537                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2538                         Perl_croak(aTHX_
2539                                 "panic: unexpected lvalue entersub "
2540                                 "args: type/targ %ld:%"UVuf,
2541                                 (long)kid->op_type, (UV)kid->op_targ);
2542                     kid = kLISTOP->op_first;
2543                 }
2544                 while (OP_HAS_SIBLING(kid))
2545                     kid = OP_SIBLING(kid);
2546                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2547                     break;      /* Postpone until runtime */
2548                 }
2549
2550                 kid = kUNOP->op_first;
2551                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2552                     kid = kUNOP->op_first;
2553                 if (kid->op_type == OP_NULL)
2554                     Perl_croak(aTHX_
2555                                "Unexpected constant lvalue entersub "
2556                                "entry via type/targ %ld:%"UVuf,
2557                                (long)kid->op_type, (UV)kid->op_targ);
2558                 if (kid->op_type != OP_GV) {
2559                     break;
2560                 }
2561
2562                 gv = kGVOP_gv;
2563                 cv = isGV(gv)
2564                     ? GvCV(gv)
2565                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
2566                         ? MUTABLE_CV(SvRV(gv))
2567                         : NULL;
2568                 if (!cv)
2569                     break;
2570                 if (CvLVALUE(cv))
2571                     break;
2572             }
2573         }
2574         /* FALLTHROUGH */
2575     default:
2576       nomod:
2577         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2578         /* grep, foreach, subcalls, refgen */
2579         if (type == OP_GREPSTART || type == OP_ENTERSUB
2580          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2581             break;
2582         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2583                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2584                       ? "do block"
2585                       : (o->op_type == OP_ENTERSUB
2586                         ? "non-lvalue subroutine call"
2587                         : OP_DESC(o))),
2588                      type ? PL_op_desc[type] : "local"));
2589         return o;
2590
2591     case OP_PREINC:
2592     case OP_PREDEC:
2593     case OP_POW:
2594     case OP_MULTIPLY:
2595     case OP_DIVIDE:
2596     case OP_MODULO:
2597     case OP_REPEAT:
2598     case OP_ADD:
2599     case OP_SUBTRACT:
2600     case OP_CONCAT:
2601     case OP_LEFT_SHIFT:
2602     case OP_RIGHT_SHIFT:
2603     case OP_BIT_AND:
2604     case OP_BIT_XOR:
2605     case OP_BIT_OR:
2606     case OP_I_MULTIPLY:
2607     case OP_I_DIVIDE:
2608     case OP_I_MODULO:
2609     case OP_I_ADD:
2610     case OP_I_SUBTRACT:
2611         if (!(o->op_flags & OPf_STACKED))
2612             goto nomod;
2613         PL_modcount++;
2614         break;
2615
2616     case OP_COND_EXPR:
2617         localize = 1;
2618         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2619             op_lvalue(kid, type);
2620         break;
2621
2622     case OP_RV2AV:
2623     case OP_RV2HV:
2624         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2625            PL_modcount = RETURN_UNLIMITED_NUMBER;
2626             return o;           /* Treat \(@foo) like ordinary list. */
2627         }
2628         /* FALLTHROUGH */
2629     case OP_RV2GV:
2630         if (scalar_mod_type(o, type))
2631             goto nomod;
2632         ref(cUNOPo->op_first, o->op_type);
2633         /* FALLTHROUGH */
2634     case OP_ASLICE:
2635     case OP_HSLICE:
2636         localize = 1;
2637         /* FALLTHROUGH */
2638     case OP_AASSIGN:
2639         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2640         if (type == OP_LEAVESUBLV && (
2641                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2642              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2643            ))
2644             o->op_private |= OPpMAYBE_LVSUB;
2645         /* FALLTHROUGH */
2646     case OP_NEXTSTATE:
2647     case OP_DBSTATE:
2648        PL_modcount = RETURN_UNLIMITED_NUMBER;
2649         break;
2650     case OP_KVHSLICE:
2651     case OP_KVASLICE:
2652         if (type == OP_LEAVESUBLV)
2653             o->op_private |= OPpMAYBE_LVSUB;
2654         goto nomod;
2655     case OP_AV2ARYLEN:
2656         PL_hints |= HINT_BLOCK_SCOPE;
2657         if (type == OP_LEAVESUBLV)
2658             o->op_private |= OPpMAYBE_LVSUB;
2659         PL_modcount++;
2660         break;
2661     case OP_RV2SV:
2662         ref(cUNOPo->op_first, o->op_type);
2663         localize = 1;
2664         /* FALLTHROUGH */
2665     case OP_GV:
2666         PL_hints |= HINT_BLOCK_SCOPE;
2667         /* FALLTHROUGH */
2668     case OP_SASSIGN:
2669     case OP_ANDASSIGN:
2670     case OP_ORASSIGN:
2671     case OP_DORASSIGN:
2672         PL_modcount++;
2673         break;
2674
2675     case OP_AELEMFAST:
2676     case OP_AELEMFAST_LEX:
2677         localize = -1;
2678         PL_modcount++;
2679         break;
2680
2681     case OP_PADAV:
2682     case OP_PADHV:
2683        PL_modcount = RETURN_UNLIMITED_NUMBER;
2684         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2685             return o;           /* Treat \(@foo) like ordinary list. */
2686         if (scalar_mod_type(o, type))
2687             goto nomod;
2688         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2689           && type == OP_LEAVESUBLV)
2690             o->op_private |= OPpMAYBE_LVSUB;
2691         /* FALLTHROUGH */
2692     case OP_PADSV:
2693         PL_modcount++;
2694         if (!type) /* local() */
2695             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2696                  PAD_COMPNAME_SV(o->op_targ));
2697         break;
2698
2699     case OP_PUSHMARK:
2700         localize = 0;
2701         break;
2702
2703     case OP_KEYS:
2704     case OP_RKEYS:
2705         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2706             goto nomod;
2707         goto lvalue_func;
2708     case OP_SUBSTR:
2709         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2710             goto nomod;
2711         /* FALLTHROUGH */
2712     case OP_POS:
2713     case OP_VEC:
2714       lvalue_func:
2715         if (type == OP_LEAVESUBLV)
2716             o->op_private |= OPpMAYBE_LVSUB;
2717         if (o->op_flags & OPf_KIDS)
2718             op_lvalue(OP_SIBLING(cBINOPo->op_first), type);
2719         break;
2720
2721     case OP_AELEM:
2722     case OP_HELEM:
2723         ref(cBINOPo->op_first, o->op_type);
2724         if (type == OP_ENTERSUB &&
2725              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2726             o->op_private |= OPpLVAL_DEFER;
2727         if (type == OP_LEAVESUBLV)
2728             o->op_private |= OPpMAYBE_LVSUB;
2729         localize = 1;
2730         PL_modcount++;
2731         break;
2732
2733     case OP_LEAVE:
2734     case OP_LEAVELOOP:
2735         o->op_private |= OPpLVALUE;
2736         /* FALLTHROUGH */
2737     case OP_SCOPE:
2738     case OP_ENTER:
2739     case OP_LINESEQ:
2740         localize = 0;
2741         if (o->op_flags & OPf_KIDS)
2742             op_lvalue(cLISTOPo->op_last, type);
2743         break;
2744
2745     case OP_NULL:
2746         localize = 0;
2747         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2748             goto nomod;
2749         else if (!(o->op_flags & OPf_KIDS))
2750             break;
2751         if (o->op_targ != OP_LIST) {
2752             op_lvalue(cBINOPo->op_first, type);
2753             break;
2754         }
2755         /* FALLTHROUGH */
2756     case OP_LIST:
2757         localize = 0;
2758         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2759             /* elements might be in void context because the list is
2760                in scalar context or because they are attribute sub calls */
2761             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2762                 op_lvalue(kid, type);
2763         break;
2764
2765     case OP_COREARGS:
2766         return o;
2767
2768     case OP_AND:
2769     case OP_OR:
2770         if (type == OP_LEAVESUBLV
2771          || !S_vivifies(cLOGOPo->op_first->op_type))
2772             op_lvalue(cLOGOPo->op_first, type);
2773         if (type == OP_LEAVESUBLV
2774          || !S_vivifies(OP_SIBLING(cLOGOPo->op_first)->op_type))
2775             op_lvalue(OP_SIBLING(cLOGOPo->op_first), type);
2776         goto nomod;
2777
2778     case OP_SREFGEN:
2779         if (type != OP_AASSIGN && type != OP_SASSIGN
2780          && type != OP_ENTERLOOP)
2781             goto nomod;
2782         /* Don’t bother applying lvalue context to the ex-list.  */
2783         kid = cUNOPx(cUNOPo->op_first)->op_first;
2784         assert (!OP_HAS_SIBLING(kid));
2785         goto kid_2lvref;
2786     case OP_REFGEN:
2787         if (type != OP_AASSIGN) goto nomod;
2788         kid = cUNOPo->op_first;
2789       kid_2lvref:
2790         {
2791             const U8 ec = PL_parser ? PL_parser->error_count : 0;
2792             S_lvref(aTHX_ kid, type);
2793             if (!PL_parser || PL_parser->error_count == ec) {
2794                 if (!FEATURE_REFALIASING_IS_ENABLED)
2795                     Perl_croak(aTHX_
2796                        "Experimental aliasing via reference not enabled");
2797                 Perl_ck_warner_d(aTHX_
2798                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
2799                                 "Aliasing via reference is experimental");
2800             }
2801         }
2802         if (o->op_type == OP_REFGEN)
2803             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
2804         op_null(o);
2805         return o;
2806     }
2807
2808     /* [20011101.069] File test operators interpret OPf_REF to mean that
2809        their argument is a filehandle; thus \stat(".") should not set
2810        it. AMS 20011102 */
2811     if (type == OP_REFGEN &&
2812         PL_check[o->op_type] == Perl_ck_ftst)
2813         return o;
2814
2815     if (type != OP_LEAVESUBLV)
2816         o->op_flags |= OPf_MOD;
2817
2818     if (type == OP_AASSIGN || type == OP_SASSIGN)
2819         o->op_flags |= OPf_SPECIAL|OPf_REF;
2820     else if (!type) { /* local() */
2821         switch (localize) {
2822         case 1:
2823             o->op_private |= OPpLVAL_INTRO;
2824             o->op_flags &= ~OPf_SPECIAL;
2825             PL_hints |= HINT_BLOCK_SCOPE;
2826             break;
2827         case 0:
2828             break;
2829         case -1:
2830             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2831                            "Useless localization of %s", OP_DESC(o));
2832         }
2833     }
2834     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2835              && type != OP_LEAVESUBLV)
2836         o->op_flags |= OPf_REF;
2837     return o;
2838 }
2839
2840 STATIC bool
2841 S_scalar_mod_type(const OP *o, I32 type)
2842 {
2843     switch (type) {
2844     case OP_POS:
2845     case OP_SASSIGN:
2846         if (o && o->op_type == OP_RV2GV)
2847             return FALSE;
2848         /* FALLTHROUGH */
2849     case OP_PREINC:
2850     case OP_PREDEC:
2851     case OP_POSTINC:
2852     case OP_POSTDEC:
2853     case OP_I_PREINC:
2854     case OP_I_PREDEC:
2855     case OP_I_POSTINC:
2856     case OP_I_POSTDEC:
2857     case OP_POW:
2858     case OP_MULTIPLY:
2859     case OP_DIVIDE:
2860     case OP_MODULO:
2861     case OP_REPEAT:
2862     case OP_ADD:
2863     case OP_SUBTRACT:
2864     case OP_I_MULTIPLY:
2865     case OP_I_DIVIDE:
2866     case OP_I_MODULO:
2867     case OP_I_ADD:
2868     case OP_I_SUBTRACT:
2869     case OP_LEFT_SHIFT:
2870     case OP_RIGHT_SHIFT:
2871     case OP_BIT_AND:
2872     case OP_BIT_XOR:
2873     case OP_BIT_OR:
2874     case OP_CONCAT:
2875     case OP_SUBST:
2876     case OP_TRANS:
2877     case OP_TRANSR:
2878     case OP_READ:
2879     case OP_SYSREAD:
2880     case OP_RECV:
2881     case OP_ANDASSIGN:
2882     case OP_ORASSIGN:
2883     case OP_DORASSIGN:
2884         return TRUE;
2885     default:
2886         return FALSE;
2887     }
2888 }
2889
2890 STATIC bool
2891 S_is_handle_constructor(const OP *o, I32 numargs)
2892 {
2893     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2894
2895     switch (o->op_type) {
2896     case OP_PIPE_OP:
2897     case OP_SOCKPAIR:
2898         if (numargs == 2)
2899             return TRUE;
2900         /* FALLTHROUGH */
2901     case OP_SYSOPEN:
2902     case OP_OPEN:
2903     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2904     case OP_SOCKET:
2905     case OP_OPEN_DIR:
2906     case OP_ACCEPT:
2907         if (numargs == 1)
2908             return TRUE;
2909         /* FALLTHROUGH */
2910     default:
2911         return FALSE;
2912     }
2913 }
2914
2915 static OP *
2916 S_refkids(pTHX_ OP *o, I32 type)
2917 {
2918     if (o && o->op_flags & OPf_KIDS) {
2919         OP *kid;
2920         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
2921             ref(kid, type);
2922     }
2923     return o;
2924 }
2925
2926 OP *
2927 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2928 {
2929     dVAR;
2930     OP *kid;
2931
2932     PERL_ARGS_ASSERT_DOREF;
2933
2934     if (!o || (PL_parser && PL_parser->error_count))
2935         return o;
2936
2937     switch (o->op_type) {
2938     case OP_ENTERSUB:
2939         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2940             !(o->op_flags & OPf_STACKED)) {
2941             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2942             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2943             assert(cUNOPo->op_first->op_type == OP_NULL);
2944             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2945             o->op_flags |= OPf_SPECIAL;
2946         }
2947         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2948             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2949                               : type == OP_RV2HV ? OPpDEREF_HV
2950                               : OPpDEREF_SV);
2951             o->op_flags |= OPf_MOD;
2952         }
2953
2954         break;
2955
2956     case OP_COND_EXPR:
2957         for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
2958             doref(kid, type, set_op_ref);
2959         break;
2960     case OP_RV2SV:
2961         if (type == OP_DEFINED)
2962             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2963         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2964         /* FALLTHROUGH */
2965     case OP_PADSV:
2966         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2967             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2968                               : type == OP_RV2HV ? OPpDEREF_HV
2969                               : OPpDEREF_SV);
2970             o->op_flags |= OPf_MOD;
2971         }
2972         break;
2973
2974     case OP_RV2AV:
2975     case OP_RV2HV:
2976         if (set_op_ref)
2977             o->op_flags |= OPf_REF;
2978         /* FALLTHROUGH */
2979     case OP_RV2GV:
2980         if (type == OP_DEFINED)
2981             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2982         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2983         break;
2984
2985     case OP_PADAV:
2986     case OP_PADHV:
2987         if (set_op_ref)
2988             o->op_flags |= OPf_REF;
2989         break;
2990
2991     case OP_SCALAR:
2992     case OP_NULL:
2993         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2994             break;
2995         doref(cBINOPo->op_first, type, set_op_ref);
2996         break;
2997     case OP_AELEM:
2998     case OP_HELEM:
2999         doref(cBINOPo->op_first, o->op_type, set_op_ref);
3000         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3001             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3002                               : type == OP_RV2HV ? OPpDEREF_HV
3003                               : OPpDEREF_SV);
3004             o->op_flags |= OPf_MOD;
3005         }
3006         break;
3007
3008     case OP_SCOPE:
3009     case OP_LEAVE:
3010         set_op_ref = FALSE;
3011         /* FALLTHROUGH */
3012     case OP_ENTER:
3013     case OP_LIST:
3014         if (!(o->op_flags & OPf_KIDS))
3015             break;
3016         doref(cLISTOPo->op_last, type, set_op_ref);
3017         break;
3018     default:
3019         break;
3020     }
3021     return scalar(o);
3022
3023 }
3024
3025 STATIC OP *
3026 S_dup_attrlist(pTHX_ OP *o)
3027 {
3028     OP *rop;
3029
3030     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3031
3032     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3033      * where the first kid is OP_PUSHMARK and the remaining ones
3034      * are OP_CONST.  We need to push the OP_CONST values.
3035      */
3036     if (o->op_type == OP_CONST)
3037         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3038     else {
3039         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3040         rop = NULL;
3041         for (o = cLISTOPo->op_first; o; o = OP_SIBLING(o)) {
3042             if (o->op_type == OP_CONST)
3043                 rop = op_append_elem(OP_LIST, rop,
3044                                   newSVOP(OP_CONST, o->op_flags,
3045                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3046         }
3047     }
3048     return rop;
3049 }
3050
3051 STATIC void
3052 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3053 {
3054     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3055
3056     PERL_ARGS_ASSERT_APPLY_ATTRS;
3057
3058     /* fake up C<use attributes $pkg,$rv,@attrs> */
3059
3060 #define ATTRSMODULE "attributes"
3061 #define ATTRSMODULE_PM "attributes.pm"
3062
3063     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3064                          newSVpvs(ATTRSMODULE),
3065                          NULL,
3066                          op_prepend_elem(OP_LIST,
3067                                       newSVOP(OP_CONST, 0, stashsv),
3068                                       op_prepend_elem(OP_LIST,
3069                                                    newSVOP(OP_CONST, 0,
3070                                                            newRV(target)),
3071                                                    dup_attrlist(attrs))));
3072 }
3073
3074 STATIC void
3075 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3076 {
3077     OP *pack, *imop, *arg;
3078     SV *meth, *stashsv, **svp;
3079
3080     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3081
3082     if (!attrs)
3083         return;
3084
3085     assert(target->op_type == OP_PADSV ||
3086            target->op_type == OP_PADHV ||
3087            target->op_type == OP_PADAV);
3088
3089     /* Ensure that attributes.pm is loaded. */
3090     /* Don't force the C<use> if we don't need it. */
3091     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3092     if (svp && *svp != &PL_sv_undef)
3093         NOOP;   /* already in %INC */
3094     else
3095         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3096                                newSVpvs(ATTRSMODULE), NULL);
3097
3098     /* Need package name for method call. */
3099     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3100
3101     /* Build up the real arg-list. */
3102     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
3103
3104     arg = newOP(OP_PADSV, 0);
3105     arg->op_targ = target->op_targ;
3106     arg = op_prepend_elem(OP_LIST,
3107                        newSVOP(OP_CONST, 0, stashsv),
3108                        op_prepend_elem(OP_LIST,
3109                                     newUNOP(OP_REFGEN, 0,
3110                                             op_lvalue(arg, OP_REFGEN)),
3111                                     dup_attrlist(attrs)));
3112
3113     /* Fake up a method call to import */
3114     meth = newSVpvs_share("import");
3115     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
3116                    op_append_elem(OP_LIST,
3117                                op_prepend_elem(OP_LIST, pack, arg),
3118                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3119
3120     /* Combine the ops. */
3121     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3122 }
3123
3124 /*
3125 =notfor apidoc apply_attrs_string
3126
3127 Attempts to apply a list of attributes specified by the C<attrstr> and
3128 C<len> arguments to the subroutine identified by the C<cv> argument which
3129 is expected to be associated with the package identified by the C<stashpv>
3130 argument (see L<attributes>).  It gets this wrong, though, in that it
3131 does not correctly identify the boundaries of the individual attribute
3132 specifications within C<attrstr>.  This is not really intended for the
3133 public API, but has to be listed here for systems such as AIX which
3134 need an explicit export list for symbols.  (It's called from XS code
3135 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3136 to respect attribute syntax properly would be welcome.
3137
3138 =cut
3139 */
3140
3141 void
3142 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3143                         const char *attrstr, STRLEN len)
3144 {
3145     OP *attrs = NULL;
3146
3147     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3148
3149     if (!len) {
3150         len = strlen(attrstr);
3151     }
3152
3153     while (len) {
3154         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3155         if (len) {
3156             const char * const sstr = attrstr;
3157             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3158             attrs = op_append_elem(OP_LIST, attrs,
3159                                 newSVOP(OP_CONST, 0,
3160                                         newSVpvn(sstr, attrstr-sstr)));
3161         }
3162     }
3163
3164     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3165                      newSVpvs(ATTRSMODULE),
3166                      NULL, op_prepend_elem(OP_LIST,
3167                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3168                                   op_prepend_elem(OP_LIST,
3169                                                newSVOP(OP_CONST, 0,
3170                                                        newRV(MUTABLE_SV(cv))),
3171                                                attrs)));
3172 }
3173
3174 STATIC void
3175 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
3176 {
3177     OP *new_proto = NULL;
3178     STRLEN pvlen;
3179     char *pv;
3180     OP *o;
3181
3182     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3183
3184     if (!*attrs)
3185         return;
3186
3187     o = *attrs;
3188     if (o->op_type == OP_CONST) {
3189         pv = SvPV(cSVOPo_sv, pvlen);
3190         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3191             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3192             SV ** const tmpo = cSVOPx_svp(o);
3193             SvREFCNT_dec(cSVOPo_sv);
3194             *tmpo = tmpsv;
3195             new_proto = o;
3196             *attrs = NULL;
3197         }
3198     } else if (o->op_type == OP_LIST) {
3199         OP * lasto;
3200         assert(o->op_flags & OPf_KIDS);
3201         lasto = cLISTOPo->op_first;
3202         assert(lasto->op_type == OP_PUSHMARK);
3203         for (o = OP_SIBLING(lasto); o; o = OP_SIBLING(o)) {
3204             if (o->op_type == OP_CONST) {
3205                 pv = SvPV(cSVOPo_sv, pvlen);
3206                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
3207                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3208                     SV ** const tmpo = cSVOPx_svp(o);
3209                     SvREFCNT_dec(cSVOPo_sv);
3210                     *tmpo = tmpsv;
3211                     if (new_proto && ckWARN(WARN_MISC)) {
3212                         STRLEN new_len;
3213                         const char * newp = SvPV(cSVOPo_sv, new_len);
3214                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3215                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
3216                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3217                         op_free(new_proto);
3218                     }
3219                     else if (new_proto)
3220                         op_free(new_proto);
3221                     new_proto = o;
3222                     /* excise new_proto from the list */
3223                     op_sibling_splice(*attrs, lasto, 1, NULL);
3224                     o = lasto;
3225                     continue;
3226                 }
3227             }
3228             lasto = o;
3229         }
3230         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
3231            would get pulled in with no real need */
3232         if (!OP_HAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
3233             op_free(*attrs);
3234             *attrs = NULL;
3235         }
3236     }
3237
3238     if (new_proto) {
3239         SV *svname;
3240         if (isGV(name)) {
3241             svname = sv_newmortal();
3242             gv_efullname3(svname, name, NULL);
3243         }
3244         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
3245             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
3246         else
3247             svname = (SV *)name;
3248         if (ckWARN(WARN_ILLEGALPROTO))
3249             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
3250         if (*proto && ckWARN(WARN_PROTOTYPE)) {
3251             STRLEN old_len, new_len;
3252             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
3253             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
3254
3255             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
3256                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
3257                 " in %"SVf,
3258                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
3259                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
3260                 SVfARG(svname));
3261         }
3262         if (*proto)
3263             op_free(*proto);
3264         *proto = new_proto;
3265     }
3266 }
3267
3268 static void
3269 S_cant_declare(pTHX_ OP *o)
3270 {
3271     if (o->op_type == OP_NULL
3272      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
3273         o = cUNOPo->op_first;
3274     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
3275                              o->op_type == OP_NULL
3276                                && o->op_flags & OPf_SPECIAL
3277                                  ? "do block"
3278                                  : OP_DESC(o),
3279                              PL_parser->in_my == KEY_our   ? "our"   :
3280                              PL_parser->in_my == KEY_state ? "state" :
3281                                                              "my"));
3282 }
3283
3284 STATIC OP *
3285 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
3286 {
3287     I32 type;
3288     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
3289
3290     PERL_ARGS_ASSERT_MY_KID;
3291
3292     if (!o || (PL_parser && PL_parser->error_count))
3293         return o;
3294
3295     type = o->op_type;
3296
3297     if (type == OP_LIST) {
3298         OP *kid;
3299         for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
3300             my_kid(kid, attrs, imopsp);
3301         return o;
3302     } else if (type == OP_UNDEF || type == OP_STUB) {
3303         return o;
3304     } else if (type == OP_RV2SV ||      /* "our" declaration */
3305                type == OP_RV2AV ||
3306                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
3307         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
3308             S_cant_declare(aTHX_ o);
3309         } else if (attrs) {
3310             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
3311             assert(PL_parser);
3312             PL_parser->in_my = FALSE;
3313             PL_parser->in_my_stash = NULL;
3314             apply_attrs(GvSTASH(gv),
3315                         (type == OP_RV2SV ? GvSV(gv) :
3316                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
3317                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
3318                         attrs);
3319         }
3320         o->op_private |= OPpOUR_INTRO;
3321         return o;
3322     }
3323     else if (type != OP_PADSV &&
3324              type != OP_PADAV &&
3325              type != OP_PADHV &&
3326              type != OP_PUSHMARK)
3327     {
3328         S_cant_declare(aTHX_ o);
3329         return o;
3330     }
3331     else if (attrs && type != OP_PUSHMARK) {
3332         HV *stash;
3333
3334         assert(PL_parser);
3335         PL_parser->in_my = FALSE;
3336         PL_parser->in_my_stash = NULL;
3337
3338         /* check for C<my Dog $spot> when deciding package */
3339         stash = PAD_COMPNAME_TYPE(o->op_targ);
3340         if (!stash)
3341             stash = PL_curstash;
3342         apply_attrs_my(stash, o, attrs, imopsp);
3343     }
3344     o->op_flags |= OPf_MOD;
3345     o->op_private |= OPpLVAL_INTRO;
3346     if (stately)
3347         o->op_private |= OPpPAD_STATE;
3348     return o;
3349 }
3350
3351 OP *
3352 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
3353 {
3354     OP *rops;
3355     int maybe_scalar = 0;
3356
3357     PERL_ARGS_ASSERT_MY_ATTRS;
3358
3359 /* [perl #17376]: this appears to be premature, and results in code such as
3360    C< our(%x); > executing in list mode rather than void mode */
3361 #if 0
3362     if (o->op_flags & OPf_PARENS)
3363         list(o);
3364     else
3365         maybe_scalar = 1;
3366 #else
3367     maybe_scalar = 1;
3368 #endif
3369     if (attrs)
3370         SAVEFREEOP(attrs);
3371     rops = NULL;
3372     o = my_kid(o, attrs, &rops);
3373     if (rops) {
3374         if (maybe_scalar && o->op_type == OP_PADSV) {
3375             o = scalar(op_append_list(OP_LIST, rops, o));
3376             o->op_private |= OPpLVAL_INTRO;
3377         }
3378         else {
3379             /* The listop in rops might have a pushmark at the beginning,
3380                which will mess up list assignment. */
3381             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
3382             if (rops->op_type == OP_LIST && 
3383                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
3384             {
3385                 OP * const pushmark = lrops->op_first;
3386                 /* excise pushmark */
3387                 op_sibling_splice(rops, NULL, 1, NULL);
3388                 op_free(pushmark);
3389             }
3390             o = op_append_list(OP_LIST, o, rops);
3391         }
3392     }
3393     PL_parser->in_my = FALSE;
3394     PL_parser->in_my_stash = NULL;
3395     return o;
3396 }
3397
3398 OP *
3399 Perl_sawparens(pTHX_ OP *o)
3400 {
3401     PERL_UNUSED_CONTEXT;
3402     if (o)
3403         o->op_flags |= OPf_PARENS;
3404     return o;
3405 }
3406
3407 OP *
3408 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3409 {
3410     OP *o;
3411     bool ismatchop = 0;
3412     const OPCODE ltype = left->op_type;
3413     const OPCODE rtype = right->op_type;
3414
3415     PERL_ARGS_ASSERT_BIND_MATCH;
3416
3417     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3418           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3419     {
3420       const char * const desc
3421           = PL_op_desc[(
3422                           rtype == OP_SUBST || rtype == OP_TRANS
3423                        || rtype == OP_TRANSR
3424                        )
3425                        ? (int)rtype : OP_MATCH];
3426       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3427       SV * const name =
3428         S_op_varname(aTHX_ left);
3429       if (name)
3430         Perl_warner(aTHX_ packWARN(WARN_MISC),
3431              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3432              desc, SVfARG(name), SVfARG(name));
3433       else {
3434         const char * const sample = (isary
3435              ? "@array" : "%hash");
3436         Perl_warner(aTHX_ packWARN(WARN_MISC),
3437              "Applying %s to %s will act on scalar(%s)",
3438              desc, sample, sample);
3439       }
3440     }
3441
3442     if (rtype == OP_CONST &&
3443         cSVOPx(right)->op_private & OPpCONST_BARE &&
3444         cSVOPx(right)->op_private & OPpCONST_STRICT)
3445     {
3446         no_bareword_allowed(right);
3447     }
3448
3449     /* !~ doesn't make sense with /r, so error on it for now */
3450     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3451         type == OP_NOT)
3452         /* diag_listed_as: Using !~ with %s doesn't make sense */
3453         yyerror("Using !~ with s///r doesn't make sense");
3454     if (rtype == OP_TRANSR && type == OP_NOT)
3455         /* diag_listed_as: Using !~ with %s doesn't make sense */
3456         yyerror("Using !~ with tr///r doesn't make sense");
3457
3458     ismatchop = (rtype == OP_MATCH ||
3459                  rtype == OP_SUBST ||
3460                  rtype == OP_TRANS || rtype == OP_TRANSR)
3461              && !(right->op_flags & OPf_SPECIAL);
3462     if (ismatchop && right->op_private & OPpTARGET_MY) {
3463         right->op_targ = 0;
3464         right->op_private &= ~OPpTARGET_MY;
3465     }
3466     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3467         OP *newleft;
3468
3469         right->op_flags |= OPf_STACKED;
3470         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3471             ! (rtype == OP_TRANS &&
3472                right->op_private & OPpTRANS_IDENTICAL) &&
3473             ! (rtype == OP_SUBST &&
3474                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3475             newleft = op_lvalue(left, rtype);
3476         else
3477             newleft = left;
3478         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3479             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3480         else
3481             o = op_prepend_elem(rtype, scalar(newleft), right);
3482         if (type == OP_NOT)
3483             return newUNOP(OP_NOT, 0, scalar(o));
3484         return o;
3485     }
3486     else
3487         return bind_match(type, left,
3488                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3489 }
3490
3491 OP *
3492 Perl_invert(pTHX_ OP *o)
3493 {
3494     if (!o)
3495         return NULL;
3496     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3497 }
3498
3499 /*
3500 =for apidoc Amx|OP *|op_scope|OP *o
3501
3502 Wraps up an op tree with some additional ops so that at runtime a dynamic
3503 scope will be created.  The original ops run in the new dynamic scope,
3504 and then, provided that they exit normally, the scope will be unwound.
3505 The additional ops used to create and unwind the dynamic scope will
3506 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3507 instead if the ops are simple enough to not need the full dynamic scope
3508 structure.
3509
3510 =cut
3511 */
3512
3513 OP *
3514 Perl_op_scope(pTHX_ OP *o)
3515 {
3516     dVAR;
3517     if (o) {
3518         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3519             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3520             o->op_type = OP_LEAVE;
3521             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3522         }
3523         else if (o->op_type == OP_LINESEQ) {
3524             OP *kid;
3525             o->op_type = OP_SCOPE;
3526             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3527             kid = ((LISTOP*)o)->op_first;
3528             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3529                 op_null(kid);
3530
3531                 /* The following deals with things like 'do {1 for 1}' */
3532                 kid = OP_SIBLING(kid);
3533                 if (kid &&
3534                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3535                     op_null(kid);
3536             }
3537         }
3538         else
3539             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3540     }
3541     return o;
3542 }
3543
3544 OP *
3545 Perl_op_unscope(pTHX_ OP *o)
3546 {
3547     if (o && o->op_type == OP_LINESEQ) {
3548         OP *kid = cLISTOPo->op_first;
3549         for(; kid; kid = OP_SIBLING(kid))
3550             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3551                 op_null(kid);
3552     }
3553     return o;
3554 }
3555
3556 int
3557 Perl_block_start(pTHX_ int full)
3558 {
3559     const int retval = PL_savestack_ix;
3560
3561     pad_block_start(full);
3562     SAVEHINTS();
3563     PL_hints &= ~HINT_BLOCK_SCOPE;
3564     SAVECOMPILEWARNINGS();
3565     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3566
3567     CALL_BLOCK_HOOKS(bhk_start, full);
3568
3569     return retval;
3570 }
3571
3572 OP*
3573 Perl_block_end(pTHX_ I32 floor, OP *seq)
3574 {
3575     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3576     OP* retval = scalarseq(seq);
3577     OP *o;
3578
3579     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3580
3581     LEAVE_SCOPE(floor);
3582     if (needblockscope)
3583         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3584     o = pad_leavemy();
3585
3586     if (o) {
3587         /* pad_leavemy has created a sequence of introcv ops for all my
3588            subs declared in the block.  We have to replicate that list with
3589            clonecv ops, to deal with this situation:
3590
3591                sub {
3592                    my sub s1;
3593                    my sub s2;
3594                    sub s1 { state sub foo { \&s2 } }
3595                }->()
3596
3597            Originally, I was going to have introcv clone the CV and turn
3598            off the stale flag.  Since &s1 is declared before &s2, the
3599            introcv op for &s1 is executed (on sub entry) before the one for
3600            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3601            cloned, since it is a state sub) closes over &s2 and expects
3602            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3603            then &s2 is still marked stale.  Since &s1 is not active, and
3604            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3605            ble will not stay shared’ warning.  Because it is the same stub
3606            that will be used when the introcv op for &s2 is executed, clos-
3607            ing over it is safe.  Hence, we have to turn off the stale flag
3608            on all lexical subs in the block before we clone any of them.
3609            Hence, having introcv clone the sub cannot work.  So we create a
3610            list of ops like this:
3611
3612                lineseq
3613                   |
3614                   +-- introcv
3615                   |
3616                   +-- introcv
3617                   |
3618                   +-- introcv
3619                   |
3620                   .
3621                   .
3622                   .
3623                   |
3624                   +-- clonecv
3625                   |
3626                   +-- clonecv
3627                   |
3628                   +-- clonecv
3629                   |
3630                   .
3631                   .
3632                   .
3633          */
3634         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3635         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3636         for (;; kid = OP_SIBLING(kid)) {
3637             OP *newkid = newOP(OP_CLONECV, 0);
3638             newkid->op_targ = kid->op_targ;
3639             o = op_append_elem(OP_LINESEQ, o, newkid);
3640             if (kid == last) break;
3641         }
3642         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3643     }
3644
3645     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3646
3647     return retval;
3648 }
3649
3650 /*
3651 =head1 Compile-time scope hooks
3652
3653 =for apidoc Aox||blockhook_register
3654
3655 Register a set of hooks to be called when the Perl lexical scope changes
3656 at compile time.  See L<perlguts/"Compile-time scope hooks">.
3657
3658 =cut
3659 */
3660
3661 void
3662 Perl_blockhook_register(pTHX_ BHK *hk)
3663 {
3664     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3665
3666     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3667 }
3668
3669 STATIC OP *
3670 S_newDEFSVOP(pTHX)
3671 {
3672     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3673     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3674         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3675     }
3676     else {
3677         OP * const o = newOP(OP_PADSV, 0);
3678         o->op_targ = offset;
3679         return o;
3680     }
3681 }
3682
3683 void
3684 Perl_newPROG(pTHX_ OP *o)
3685 {
3686     PERL_ARGS_ASSERT_NEWPROG;
3687
3688     if (PL_in_eval) {
3689         PERL_CONTEXT *cx;
3690         I32 i;
3691         if (PL_eval_root)
3692                 return;
3693         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3694                                ((PL_in_eval & EVAL_KEEPERR)
3695                                 ? OPf_SPECIAL : 0), o);
3696
3697         cx = &cxstack[cxstack_ix];
3698         assert(CxTYPE(cx) == CXt_EVAL);
3699
3700         if ((cx->blk_gimme & G_WANT) == G_VOID)
3701             scalarvoid(PL_eval_root);
3702         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3703             list(PL_eval_root);
3704         else
3705             scalar(PL_eval_root);
3706
3707         PL_eval_start = op_linklist(PL_eval_root);
3708         PL_eval_root->op_private |= OPpREFCOUNTED;
3709         OpREFCNT_set(PL_eval_root, 1);
3710         PL_eval_root->op_next = 0;
3711         i = PL_savestack_ix;
3712         SAVEFREEOP(o);
3713         ENTER;
3714         CALL_PEEP(PL_eval_start);
3715         finalize_optree(PL_eval_root);
3716         S_prune_chain_head(&PL_eval_start);
3717         LEAVE;
3718         PL_savestack_ix = i;
3719     }
3720     else {
3721         if (o->op_type == OP_STUB) {
3722             /* This block is entered if nothing is compiled for the main
3723                program. This will be the case for an genuinely empty main
3724                program, or one which only has BEGIN blocks etc, so already
3725                run and freed.
3726
3727                Historically (5.000) the guard above was !o. However, commit
3728                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3729                c71fccf11fde0068, changed perly.y so that newPROG() is now
3730                called with the output of block_end(), which returns a new
3731                OP_STUB for the case of an empty optree. ByteLoader (and
3732                maybe other things) also take this path, because they set up
3733                PL_main_start and PL_main_root directly, without generating an
3734                optree.
3735
3736                If the parsing the main program aborts (due to parse errors,
3737                or due to BEGIN or similar calling exit), then newPROG()
3738                isn't even called, and hence this code path and its cleanups
3739                are skipped. This shouldn't make a make a difference:
3740                * a non-zero return from perl_parse is a failure, and
3741                  perl_destruct() should be called immediately.
3742                * however, if exit(0) is called during the parse, then
3743                  perl_parse() returns 0, and perl_run() is called. As
3744                  PL_main_start will be NULL, perl_run() will return
3745                  promptly, and the exit code will remain 0.
3746             */
3747
3748             PL_comppad_name = 0;
3749             PL_compcv = 0;
3750             S_op_destroy(aTHX_ o);
3751             return;
3752         }
3753         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3754         PL_curcop = &PL_compiling;
3755         PL_main_start = LINKLIST(PL_main_root);
3756         PL_main_root->op_private |= OPpREFCOUNTED;
3757         OpREFCNT_set(PL_main_root, 1);
3758         PL_main_root->op_next = 0;
3759         CALL_PEEP(PL_main_start);
3760         finalize_optree(PL_main_root);
3761         S_prune_chain_head(&PL_main_start);
3762         cv_forget_slab(PL_compcv);
3763         PL_compcv = 0;
3764
3765         /* Register with debugger */
3766         if (PERLDB_INTER) {
3767             CV * const cv = get_cvs("DB::postponed", 0);
3768             if (cv) {
3769                 dSP;
3770                 PUSHMARK(SP);
3771                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3772                 PUTBACK;
3773                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3774             }
3775         }
3776     }
3777 }
3778
3779 OP *
3780 Perl_localize(pTHX_ OP *o, I32 lex)
3781 {
3782     PERL_ARGS_ASSERT_LOCALIZE;
3783
3784     if (o->op_flags & OPf_PARENS)
3785 /* [perl #17376]: this appears to be premature, and results in code such as
3786    C< our(%x); > executing in list mode rather than void mode */
3787 #if 0
3788         list(o);
3789 #else
3790         NOOP;
3791 #endif
3792     else {
3793         if ( PL_parser->bufptr > PL_parser->oldbufptr
3794             && PL_parser->bufptr[-1] == ','
3795             && ckWARN(WARN_PARENTHESIS))
3796         {
3797             char *s = PL_parser->bufptr;
3798             bool sigil = FALSE;
3799
3800             /* some heuristics to detect a potential error */
3801             while (*s && (strchr(", \t\n", *s)))
3802                 s++;
3803
3804             while (1) {
3805                 if (*s && strchr("@$%*", *s) && *++s
3806                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3807                     s++;
3808                     sigil = TRUE;
3809                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3810                         s++;
3811                     while (*s && (strchr(", \t\n", *s)))
3812                         s++;
3813                 }
3814                 else
3815                     break;
3816             }
3817             if (sigil && (*s == ';' || *s == '=')) {
3818                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3819                                 "Parentheses missing around \"%s\" list",
3820                                 lex
3821                                     ? (PL_parser->in_my == KEY_our
3822                                         ? "our"
3823                                         : PL_parser->in_my == KEY_state
3824                                             ? "state"
3825                                             : "my")
3826                                     : "local");
3827             }
3828         }
3829     }
3830     if (lex)
3831         o = my(o);
3832     else
3833         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3834     PL_parser->in_my = FALSE;
3835     PL_parser->in_my_stash = NULL;
3836     return o;
3837 }
3838
3839 OP *
3840 Perl_jmaybe(pTHX_ OP *o)
3841 {
3842     PERL_ARGS_ASSERT_JMAYBE;
3843
3844     if (o->op_type == OP_LIST) {
3845         OP * const o2
3846             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3847         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3848     }
3849     return o;
3850 }
3851
3852 PERL_STATIC_INLINE OP *
3853 S_op_std_init(pTHX_ OP *o)
3854 {
3855     I32 type = o->op_type;
3856
3857     PERL_ARGS_ASSERT_OP_STD_INIT;
3858
3859     if (PL_opargs[type] & OA_RETSCALAR)
3860         scalar(o);
3861     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3862         o->op_targ = pad_alloc(type, SVs_PADTMP);
3863
3864     return o;
3865 }
3866
3867 PERL_STATIC_INLINE OP *
3868 S_op_integerize(pTHX_ OP *o)
3869 {
3870     I32 type = o->op_type;
3871
3872     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3873
3874     /* integerize op. */
3875     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3876     {
3877         dVAR;
3878         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3879     }
3880
3881     if (type == OP_NEGATE)
3882         /* XXX might want a ck_negate() for this */
3883         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3884
3885     return o;
3886 }
3887
3888 static OP *
3889 S_fold_constants(pTHX_ OP *o)
3890 {
3891     dVAR;
3892     OP * VOL curop;
3893     OP *newop;
3894     VOL I32 type = o->op_type;
3895     bool folded;
3896     SV * VOL sv = NULL;
3897     int ret = 0;
3898     I32 oldscope;
3899     OP *old_next;
3900     SV * const oldwarnhook = PL_warnhook;
3901     SV * const olddiehook  = PL_diehook;
3902     COP not_compiling;
3903     U8 oldwarn = PL_dowarn;
3904     dJMPENV;
3905
3906     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3907
3908     if (!(PL_opargs[type] & OA_FOLDCONST))
3909         goto nope;
3910
3911     switch (type) {
3912     case OP_UCFIRST:
3913     case OP_LCFIRST:
3914     case OP_UC:
3915     case OP_LC:
3916     case OP_FC:
3917 #ifdef USE_LOCALE_CTYPE
3918         if (IN_LC_COMPILETIME(LC_CTYPE))
3919             goto nope;
3920 #endif
3921         break;
3922     case OP_SLT:
3923     case OP_SGT:
3924     case OP_SLE:
3925     case OP_SGE:
3926     case OP_SCMP:
3927 #ifdef USE_LOCALE_COLLATE
3928         if (IN_LC_COMPILETIME(LC_COLLATE))
3929             goto nope;
3930 #endif
3931         break;
3932     case OP_SPRINTF:
3933         /* XXX what about the numeric ops? */
3934 #ifdef USE_LOCALE_NUMERIC
3935         if (IN_LC_COMPILETIME(LC_NUMERIC))
3936             goto nope;
3937 #endif
3938         break;
3939     case OP_PACK:
3940         if (!OP_HAS_SIBLING(cLISTOPo->op_first)
3941           || OP_SIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
3942             goto nope;
3943         {
3944             SV * const sv = cSVOPx_sv(OP_SIBLING(cLISTOPo->op_first));
3945             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3946             {
3947                 const char *s = SvPVX_const(sv);
3948                 while (s < SvEND(sv)) {
3949                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
3950                     s++;
3951                 }
3952             }
3953         }
3954         break;
3955     case OP_REPEAT:
3956         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3957         break;
3958     case OP_SREFGEN:
3959         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3960          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3961             goto nope;
3962     }
3963
3964     if (PL_parser && PL_parser->error_count)
3965         goto nope;              /* Don't try to run w/ errors */
3966
3967     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3968         const OPCODE type = curop->op_type;
3969         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3970             type != OP_LIST &&
3971             type != OP_SCALAR &&
3972             type != OP_NULL &&
3973             type != OP_PUSHMARK)
3974         {
3975             goto nope;
3976         }
3977     }
3978
3979     curop = LINKLIST(o);
3980     old_next = o->op_next;
3981     o->op_next = 0;
3982     PL_op = curop;
3983
3984     oldscope = PL_scopestack_ix;
3985     create_eval_scope(G_FAKINGEVAL);
3986
3987     /* Verify that we don't need to save it:  */
3988     assert(PL_curcop == &PL_compiling);
3989     StructCopy(&PL_compiling, &not_compiling, COP);
3990     PL_curcop = &not_compiling;
3991     /* The above ensures that we run with all the correct hints of the
3992        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3993     assert(IN_PERL_RUNTIME);
3994     PL_warnhook = PERL_WARNHOOK_FATAL;
3995     PL_diehook  = NULL;
3996     JMPENV_PUSH(ret);
3997
3998     /* Effective $^W=1.  */
3999     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4000         PL_dowarn |= G_WARN_ON;
4001
4002     switch (ret) {
4003     case 0:
4004         CALLRUNOPS(aTHX);
4005         sv = *(PL_stack_sp--);
4006         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
4007             pad_swipe(o->op_targ,  FALSE);
4008         }
4009         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
4010             SvREFCNT_inc_simple_void(sv);
4011             SvTEMP_off(sv);
4012         }
4013         else { assert(SvIMMORTAL(sv)); }
4014         break;
4015     case 3:
4016         /* Something tried to die.  Abandon constant folding.  */
4017         /* Pretend the error never happened.  */
4018         CLEAR_ERRSV();
4019         o->op_next = old_next;
4020         break;
4021     default:
4022         JMPENV_POP;
4023         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4024         PL_warnhook = oldwarnhook;
4025         PL_diehook  = olddiehook;
4026         /* XXX note that this croak may fail as we've already blown away
4027          * the stack - eg any nested evals */
4028         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4029     }
4030     JMPENV_POP;
4031     PL_dowarn   = oldwarn;
4032     PL_warnhook = oldwarnhook;
4033     PL_diehook  = olddiehook;
4034     PL_curcop = &PL_compiling;
4035
4036     if (PL_scopestack_ix > oldscope)
4037         delete_eval_scope();
4038
4039     if (ret)
4040         goto nope;
4041
4042     folded = cBOOL(o->op_folded);
4043     op_free(o);
4044     assert(sv);
4045     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
4046     else if (!SvIMMORTAL(sv)) {
4047         SvPADTMP_on(sv);
4048         SvREADONLY_on(sv);
4049     }
4050     if (type == OP_RV2GV)
4051         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
4052     else
4053     {
4054         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
4055         /* OP_STRINGIFY and constant folding are used to implement qq.
4056            Here the constant folding is an implementation detail that we
4057            want to hide.  If the stringify op is itself already marked
4058            folded, however, then it is actually a folded join.  */
4059         if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
4060     }
4061     return newop;
4062
4063  nope:
4064     return o;
4065 }
4066
4067 static OP *
4068 S_gen_constant_list(pTHX_ OP *o)
4069 {
4070     dVAR;
4071     OP *curop;
4072     const SSize_t oldtmps_floor = PL_tmps_floor;
4073     SV **svp;
4074     AV *av;
4075
4076     list(o);
4077     if (PL_parser && PL_parser->error_count)
4078         return o;               /* Don't attempt to run with errors */
4079
4080     curop = LINKLIST(o);
4081     o->op_next = 0;
4082     CALL_PEEP(curop);
4083     S_prune_chain_head(&curop);
4084     PL_op = curop;
4085     Perl_pp_pushmark(aTHX);
4086     CALLRUNOPS(aTHX);
4087     PL_op = curop;
4088     assert (!(curop->op_flags & OPf_SPECIAL));
4089     assert(curop->op_type == OP_RANGE);
4090     Perl_pp_anonlist(aTHX);
4091     PL_tmps_floor = oldtmps_floor;
4092
4093     o->op_type = OP_RV2AV;
4094     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4095     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
4096     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
4097     o->op_opt = 0;              /* needs to be revisited in rpeep() */
4098     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
4099
4100     /* replace subtree with an OP_CONST */
4101     curop = ((UNOP*)o)->op_first;
4102     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
4103     op_free(curop);
4104
4105     if (AvFILLp(av) != -1)
4106         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
4107         {
4108             SvPADTMP_on(*svp);
4109             SvREADONLY_on(*svp);
4110         }
4111     LINKLIST(o);
4112     return list(o);
4113 }
4114
4115 /* convert o (and any siblings) into a list if not already, then
4116  * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
4117  */
4118
4119 OP *
4120 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
4121 {
4122     dVAR;
4123     if (type < 0) type = -type, flags |= OPf_SPECIAL;
4124     if (!o || o->op_type != OP_LIST)
4125         o = force_list(o, 0);
4126     else
4127         o->op_flags &= ~OPf_WANT;
4128
4129     if (!(PL_opargs[type] & OA_MARK))
4130         op_null(cLISTOPo->op_first);
4131     else {
4132         OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
4133         if (kid2 && kid2->op_type == OP_COREARGS) {
4134             op_null(cLISTOPo->op_first);
4135             kid2->op_private |= OPpCOREARGS_PUSHMARK;
4136         }
4137     }   
4138
4139     o->op_type = (OPCODE)type;
4140     o->op_ppaddr = PL_ppaddr[type];
4141     o->op_flags |= flags;
4142
4143     o = CHECKOP(type, o);
4144     if (o->op_type != (unsigned)type)
4145         return o;
4146
4147     return fold_constants(op_integerize(op_std_init(o)));
4148 }
4149
4150 /*
4151 =head1 Optree Manipulation Functions
4152 */
4153
4154 /* List constructors */
4155
4156 /*
4157 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
4158
4159 Append an item to the list of ops contained directly within a list-type
4160 op, returning the lengthened list.  I<first> is the list-type op,
4161 and I<last> is the op to append to the list.  I<optype> specifies the
4162 intended opcode for the list.  If I<first> is not already a list of the
4163 right type, it will be upgraded into one.  If either I<first> or I<last>
4164 is null, the other is returned unchanged.
4165
4166 =cut
4167 */
4168
4169 OP *
4170 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
4171 {
4172     if (!first)
4173         return last;
4174
4175     if (!last)
4176         return first;
4177
4178     if (first->op_type != (unsigned)type
4179         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
4180     {
4181         return newLISTOP(type, 0, first, last);
4182     }
4183
4184     op_sibling_splice(first, ((LISTOP*)first)->op_last, 0, last);
4185     first->op_flags |= OPf_KIDS;
4186     return first;
4187 }
4188
4189 /*
4190 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
4191
4192 Concatenate the lists of ops contained directly within two list-type ops,
4193 returning the combined list.  I<first> and I<last> are the list-type ops
4194 to concatenate.  I<optype> specifies the intended opcode for the list.
4195 If either I<first> or I<last> is not already a list of the right type,
4196 it will be upgraded into one.  If either I<first> or I<last> is null,
4197 the other is returned unchanged.
4198
4199 =cut
4200 */
4201
4202 OP *
4203 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
4204 {
4205     if (!first)
4206         return last;
4207
4208     if (!last)
4209         return first;
4210
4211     if (first->op_type != (unsigned)type)
4212         return op_prepend_elem(type, first, last);
4213
4214     if (last->op_type != (unsigned)type)
4215         return op_append_elem(type, first, last);
4216
4217     ((LISTOP*)first)->op_last->op_lastsib = 0;
4218     OP_SIBLING_set(((LISTOP*)first)->op_last, ((LISTOP*)last)->op_first);
4219     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
4220     ((LISTOP*)first)->op_last->op_lastsib = 1;
4221 #ifdef PERL_OP_PARENT
4222     ((LISTOP*)first)->op_last->op_sibling = first;
4223 #endif
4224     first->op_flags |= (last->op_flags & OPf_KIDS);
4225
4226
4227     S_op_destroy(aTHX_ last);
4228
4229     return first;
4230 }
4231
4232 /*
4233 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
4234
4235 Prepend an item to the list of ops contained directly within a list-type
4236 op, returning the lengthened list.  I<first> is the op to prepend to the
4237 list, and I<last> is the list-type op.  I<optype> specifies the intended
4238 opcode for the list.  If I<last> is not already a list of the right type,
4239 it will be upgraded into one.  If either I<first> or I<last> is null,
4240 the other is returned unchanged.
4241
4242 =cut
4243 */
4244
4245 OP *
4246 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
4247 {
4248     if (!first)
4249         return last;
4250
4251     if (!last)
4252         return first;
4253
4254     if (last->op_type == (unsigned)type) {
4255         if (type == OP_LIST) {  /* already a PUSHMARK there */
4256             /* insert 'first' after pushmark */
4257             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
4258             if (!(first->op_flags & OPf_PARENS))
4259                 last->op_flags &= ~OPf_PARENS;
4260         }
4261         else
4262             op_sibling_splice(last, NULL, 0, first);
4263         last->op_flags |= OPf_KIDS;
4264         return last;
4265     }
4266
4267     return newLISTOP(type, 0, first, last);
4268 }
4269
4270 /* Constructors */
4271
4272
4273 /*
4274 =head1 Optree construction
4275
4276 =for apidoc Am|OP *|newNULLLIST
4277
4278 Constructs, checks, and returns a new C<stub> op, which represents an
4279 empty list expression.
4280
4281 =cut
4282 */
4283
4284 OP *
4285 Perl_newNULLLIST(pTHX)
4286 {
4287     return newOP(OP_STUB, 0);
4288 }
4289
4290 /* promote o and any siblings to be a list if its not already; i.e.
4291  *
4292  *  o - A - B
4293  *
4294  * becomes
4295  *
4296  *  list
4297  *    |
4298  *  pushmark - o - A - B
4299  *
4300  * If nullit it true, the list op is nulled.
4301  */
4302
4303 static OP *
4304 S_force_list(pTHX_ OP *o, bool nullit)
4305 {
4306     if (!o || o->op_type != OP_LIST) {
4307         OP *rest = NULL;
4308         if (o) {
4309             /* manually detach any siblings then add them back later */
4310             rest = OP_SIBLING(o);
4311             OP_SIBLING_set(o, NULL);
4312             o->op_lastsib = 1;
4313         }
4314         o = newLISTOP(OP_LIST, 0, o, NULL);
4315         if (rest)
4316             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
4317     }
4318     if (nullit)
4319         op_null(o);
4320     return o;
4321 }
4322
4323 /*
4324 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4325
4326 Constructs, checks, and returns an op of any list type.  I<type> is
4327 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4328 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4329 supply up to two ops to be direct children of the list op; they are
4330 consumed by this function and become part of the constructed op tree.
4331
4332 =cut
4333 */
4334
4335 OP *
4336 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4337 {
4338     dVAR;
4339     LISTOP *listop;
4340
4341     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4342
4343     NewOp(1101, listop, 1, LISTOP);
4344
4345     listop->op_type = (OPCODE)type;
4346     listop->op_ppaddr = PL_ppaddr[type];
4347     if (first || last)
4348         flags |= OPf_KIDS;
4349     listop->op_flags = (U8)flags;
4350
4351     if (!last && first)
4352         last = first;
4353     else if (!first && last)
4354         first = last;
4355     else if (first)
4356         OP_SIBLING_set(first, last);
4357     listop->op_first = first;
4358     listop->op_last = last;
4359     if (type == OP_LIST) {
4360         OP* const pushop = newOP(OP_PUSHMARK, 0);
4361         pushop->op_lastsib = 0;
4362         OP_SIBLING_set(pushop, first);
4363         listop->op_first = pushop;
4364         listop->op_flags |= OPf_KIDS;
4365         if (!last)
4366             listop->op_last = pushop;
4367     }
4368     if (first)
4369         first->op_lastsib = 0;
4370     if (listop->op_last) {
4371         listop->op_last->op_lastsib = 1;
4372 #ifdef PERL_OP_PARENT
4373         listop->op_last->op_sibling = (OP*)listop;
4374 #endif
4375     }
4376
4377     return CHECKOP(type, listop);
4378 }
4379
4380 /*
4381 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4382
4383 Constructs, checks, and returns an op of any base type (any type that
4384 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4385 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4386 of C<op_private>.
4387
4388 =cut
4389 */
4390
4391 OP *
4392 Perl_newOP(pTHX_ I32 type, I32 flags)
4393 {
4394     dVAR;
4395     OP *o;
4396
4397     if (type == -OP_ENTEREVAL) {
4398         type = OP_ENTEREVAL;
4399         flags |= OPpEVAL_BYTES<<8;
4400     }
4401
4402     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4403         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4404         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4405         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4406
4407     NewOp(1101, o, 1, OP);
4408     o->op_type = (OPCODE)type;
4409     o->op_ppaddr = PL_ppaddr[type];
4410     o->op_flags = (U8)flags;
4411
4412     o->op_next = o;
4413     o->op_private = (U8)(0 | (flags >> 8));
4414     if (PL_opargs[type] & OA_RETSCALAR)
4415         scalar(o);
4416     if (PL_opargs[type] & OA_TARGET)
4417         o->op_targ = pad_alloc(type, SVs_PADTMP);
4418     return CHECKOP(type, o);
4419 }
4420
4421 /*
4422 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4423
4424 Constructs, checks, and returns an op of any unary type.  I<type> is
4425 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4426 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4427 bits, the eight bits of C<op_private>, except that the bit with value 1
4428 is automatically set.  I<first> supplies an optional op to be the direct
4429 child of the unary op; it is consumed by this function and become part
4430 of the constructed op tree.
4431
4432 =cut
4433 */
4434
4435 OP *
4436 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4437 {
4438     dVAR;
4439     UNOP *unop;
4440
4441     if (type == -OP_ENTEREVAL) {
4442         type = OP_ENTEREVAL;
4443         flags |= OPpEVAL_BYTES<<8;
4444     }
4445
4446     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4447         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4448         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4449         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4450         || type == OP_SASSIGN
4451         || type == OP_ENTERTRY
4452         || type == OP_NULL );
4453
4454     if (!first)
4455         first = newOP(OP_STUB, 0);
4456     if (PL_opargs[type] & OA_MARK)
4457         first = force_list(first, 1);
4458
4459     NewOp(1101, unop, 1, UNOP);
4460     unop->op_type = (OPCODE)type;
4461     unop->op_ppaddr = PL_ppaddr[type];
4462     unop->op_first = first;
4463     unop->op_flags = (U8)(flags | OPf_KIDS);
4464     unop->op_private = (U8)(1 | (flags >> 8));
4465
4466 #ifdef PERL_OP_PARENT
4467     if (!OP_HAS_SIBLING(first)) /* true unless weird syntax error */
4468         first->op_sibling = (OP*)unop;
4469 #endif
4470
4471     unop = (UNOP*) CHECKOP(type, unop);
4472     if (unop->op_next)
4473         return (OP*)unop;
4474
4475     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4476 }
4477
4478 /*
4479 =for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
4480
4481 Constructs, checks, and returns an op of method type with a method name
4482 evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
4483 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
4484 and, shifted up eight bits, the eight bits of C<op_private>, except that
4485 the bit with value 1 is automatically set. I<dynamic_meth> supplies an
4486 op which evaluates method name; it is consumed by this function and
4487 become part of the constructed op tree.
4488 Supported optypes: OP_METHOD.
4489
4490 =cut
4491 */
4492
4493 static OP*
4494 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
4495     dVAR;
4496     METHOP *methop;
4497
4498     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP);
4499
4500     NewOp(1101, methop, 1, METHOP);
4501     if (dynamic_meth) {
4502         if (PL_opargs[type] & OA_MARK) dynamic_meth = force_list(dynamic_meth, 1);
4503         methop->op_flags = (U8)(flags | OPf_KIDS);
4504         methop->op_u.op_first = dynamic_meth;
4505         methop->op_private = (U8)(1 | (flags >> 8));
4506     }
4507     else {
4508         assert(const_meth);
4509         methop->op_flags = (U8)(flags & ~OPf_KIDS);
4510         methop->op_u.op_meth_sv = const_meth;
4511         methop->op_private = (U8)(0 | (flags >> 8));
4512         methop->op_next = (OP*)methop;
4513     }
4514
4515     methop->op_type = (OPCODE)type;
4516     methop->op_ppaddr = PL_ppaddr[type];
4517     methop = (METHOP*) CHECKOP(type, methop);
4518
4519     if (methop->op_next) return (OP*)methop;
4520
4521     return fold_constants(op_integerize(op_std_init((OP *) methop)));
4522 }
4523
4524 OP *
4525 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
4526     PERL_ARGS_ASSERT_NEWMETHOP;
4527     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
4528 }
4529
4530 /*
4531 =for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
4532
4533 Constructs, checks, and returns an op of method type with a constant
4534 method name. I<type> is the opcode. I<flags> gives the eight bits of
4535 C<op_flags>, and, shifted up eight bits, the eight bits of
4536 C<op_private>. I<const_meth> supplies a constant method name;
4537 it must be a shared COW string.
4538 Supported optypes: OP_METHOD_NAMED.
4539
4540 =cut
4541 */
4542
4543 OP *
4544 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
4545     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
4546     return newMETHOP_internal(type, flags, NULL, const_meth);
4547 }
4548
4549 /*
4550 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4551
4552 Constructs, checks, and returns an op of any binary type.  I<type>
4553 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4554 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4555 the eight bits of C<op_private>, except that the bit with value 1 or
4556 2 is automatically set as required.  I<first> and I<last> supply up to
4557 two ops to be the direct children of the binary op; they are consumed
4558 by this function and become part of the constructed op tree.
4559
4560 =cut
4561 */
4562
4563 OP *
4564 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4565 {
4566     dVAR;
4567     BINOP *binop;
4568
4569     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4570         || type == OP_SASSIGN || type == OP_NULL );
4571
4572     NewOp(1101, binop, 1, BINOP);
4573
4574     if (!first)
4575         first = newOP(OP_NULL, 0);
4576
4577     binop->op_type = (OPCODE)type;
4578     binop->op_ppaddr = PL_ppaddr[type];
4579     binop->op_first = first;
4580     binop->op_flags = (U8)(flags | OPf_KIDS);
4581     if (!last) {
4582         last = first;
4583         binop->op_private = (U8)(1 | (flags >> 8));
4584     }
4585     else {
4586         binop->op_private = (U8)(2 | (flags >> 8));
4587         OP_SIBLING_set(first, last);
4588         first->op_lastsib = 0;
4589     }
4590
4591 #ifdef PERL_OP_PARENT
4592     if (!OP_HAS_SIBLING(last)) /* true unless weird syntax error */
4593         last->op_sibling = (OP*)binop;
4594 #endif
4595
4596     binop->op_last = OP_SIBLING(binop->op_first);
4597 #ifdef PERL_OP_PARENT
4598     if (binop->op_last)
4599         binop->op_last->op_sibling = (OP*)binop;
4600 #endif
4601
4602     binop = (BINOP*)CHECKOP(type, binop);
4603     if (binop->op_next || binop->op_type != (OPCODE)type)
4604         return (OP*)binop;
4605
4606     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4607 }
4608
4609 static int uvcompare(const void *a, const void *b)
4610     __attribute__nonnull__(1)
4611     __attribute__nonnull__(2)
4612     __attribute__pure__;
4613 static int uvcompare(const void *a, const void *b)
4614 {
4615     if (*((const UV *)a) < (*(const UV *)b))
4616         return -1;
4617     if (*((const UV *)a) > (*(const UV *)b))
4618         return 1;
4619     if (*((const UV *)a+1) < (*(const UV *)b+1))
4620         return -1;
4621     if (*((const UV *)a+1) > (*(const UV *)b+1))
4622         return 1;
4623     return 0;
4624 }
4625
4626 static OP *
4627 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4628 {
4629     SV * const tstr = ((SVOP*)expr)->op_sv;
4630     SV * const rstr =
4631                               ((SVOP*)repl)->op_sv;
4632     STRLEN tlen;
4633     STRLEN rlen;
4634     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4635     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4636     I32 i;
4637     I32 j;
4638     I32 grows = 0;
4639     short *tbl;
4640
4641     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4642     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4643     I32 del              = o->op_private & OPpTRANS_DELETE;
4644     SV* swash;
4645
4646     PERL_ARGS_ASSERT_PMTRANS;
4647
4648     PL_hints |= HINT_BLOCK_SCOPE;
4649
4650     if (SvUTF8(tstr))
4651         o->op_private |= OPpTRANS_FROM_UTF;
4652
4653     if (SvUTF8(rstr))
4654         o->op_private |= OPpTRANS_TO_UTF;
4655
4656     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4657         SV* const listsv = newSVpvs("# comment\n");
4658         SV* transv = NULL;
4659         const U8* tend = t + tlen;
4660         const U8* rend = r + rlen;
4661         STRLEN ulen;
4662         UV tfirst = 1;
4663         UV tlast = 0;
4664         IV tdiff;
4665         UV rfirst = 1;
4666         UV rlast = 0;
4667         IV rdiff;
4668         IV diff;
4669         I32 none = 0;
4670         U32 max = 0;
4671         I32 bits;
4672         I32 havefinal = 0;
4673         U32 final = 0;
4674         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4675         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4676         U8* tsave = NULL;
4677         U8* rsave = NULL;
4678         const U32 flags = UTF8_ALLOW_DEFAULT;
4679
4680         if (!from_utf) {
4681             STRLEN len = tlen;
4682             t = tsave = bytes_to_utf8(t, &len);
4683             tend = t + len;
4684         }
4685         if (!to_utf && rlen) {
4686             STRLEN len = rlen;
4687             r = rsave = bytes_to_utf8(r, &len);
4688             rend = r + len;
4689         }
4690
4691 /* There is a snag with this code on EBCDIC: scan_const() in toke.c has
4692  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4693  * odd.  */
4694
4695         if (complement) {
4696             U8 tmpbuf[UTF8_MAXBYTES+1];
4697             UV *cp;
4698             UV nextmin = 0;
4699             Newx(cp, 2*tlen, UV);
4700             i = 0;
4701             transv = newSVpvs("");
4702             while (t < tend) {
4703                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4704                 t += ulen;
4705                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4706                     t++;
4707                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4708                     t += ulen;
4709                 }
4710                 else {
4711                  cp[2*i+1] = cp[2*i];
4712                 }
4713                 i++;
4714             }
4715             qsort(cp, i, 2*sizeof(UV), uvcompare);
4716             for (j = 0; j < i; j++) {
4717                 UV  val = cp[2*j];
4718                 diff = val - nextmin;
4719                 if (diff > 0) {
4720                     t = uvchr_to_utf8(tmpbuf,nextmin);
4721                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4722                     if (diff > 1) {
4723                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4724                         t = uvchr_to_utf8(tmpbuf, val - 1);
4725                         sv_catpvn(transv, (char *)&range_mark, 1);
4726                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4727                     }
4728                 }
4729                 val = cp[2*j+1];
4730                 if (val >= nextmin)
4731                     nextmin = val + 1;
4732             }
4733             t = uvchr_to_utf8(tmpbuf,nextmin);
4734             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4735             {
4736                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4737                 sv_catpvn(transv, (char *)&range_mark, 1);
4738             }
4739             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4740             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4741             t = (const U8*)SvPVX_const(transv);
4742             tlen = SvCUR(transv);
4743             tend = t + tlen;
4744             Safefree(cp);
4745         }
4746         else if (!rlen && !del) {
4747             r = t; rlen = tlen; rend = tend;
4748         }
4749         if (!squash) {
4750                 if ((!rlen && !del) || t == r ||
4751                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4752                 {
4753                     o->op_private |= OPpTRANS_IDENTICAL;
4754                 }
4755         }
4756
4757         while (t < tend || tfirst <= tlast) {
4758             /* see if we need more "t" chars */
4759             if (tfirst > tlast) {
4760                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4761                 t += ulen;
4762                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4763                     t++;
4764                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4765                     t += ulen;
4766                 }
4767                 else
4768                     tlast = tfirst;
4769             }
4770
4771             /* now see if we need more "r" chars */
4772             if (rfirst > rlast) {
4773                 if (r < rend) {
4774                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4775                     r += ulen;
4776                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4777                         r++;
4778                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4779                         r += ulen;
4780                     }
4781                     else
4782                         rlast = rfirst;
4783                 }
4784                 else {
4785                     if (!havefinal++)
4786                         final = rlast;
4787                     rfirst = rlast = 0xffffffff;
4788                 }
4789             }
4790
4791             /* now see which range will peter our first, if either. */
4792             tdiff = tlast - tfirst;
4793             rdiff = rlast - rfirst;
4794
4795             if (tdiff <= rdiff)
4796                 diff = tdiff;
4797             else
4798                 diff = rdiff;
4799
4800             if (rfirst == 0xffffffff) {
4801                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4802                 if (diff > 0)
4803                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4804                                    (long)tfirst, (long)tlast);
4805                 else
4806                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4807             }
4808             else {
4809                 if (diff > 0)
4810                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4811                                    (long)tfirst, (long)(tfirst + diff),
4812                                    (long)rfirst);
4813                 else
4814                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4815                                    (long)tfirst, (long)rfirst);
4816
4817                 if (rfirst + diff > max)
4818                     max = rfirst + diff;
4819                 if (!grows)
4820                     grows = (tfirst < rfirst &&
4821                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4822                 rfirst += diff + 1;
4823             }
4824             tfirst += diff + 1;
4825         }
4826
4827         none = ++max;
4828         if (del)
4829             del = ++max;
4830
4831         if (max > 0xffff)
4832             bits = 32;
4833         else if (max > 0xff)
4834             bits = 16;
4835         else
4836             bits = 8;
4837
4838         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4839 #ifdef USE_ITHREADS
4840         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4841         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4842         PAD_SETSV(cPADOPo->op_padix, swash);
4843         SvPADTMP_on(swash);
4844         SvREADONLY_on(swash);
4845 #else
4846         cSVOPo->op_sv = swash;
4847 #endif
4848         SvREFCNT_dec(listsv);
4849         SvREFCNT_dec(transv);
4850
4851         if (!del && havefinal && rlen)
4852             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4853                            newSVuv((UV)final), 0);
4854
4855         if (grows)
4856             o->op_private |= OPpTRANS_GROWS;
4857
4858         Safefree(tsave);
4859         Safefree(rsave);
4860
4861         op_free(expr);
4862         op_free(repl);
4863         return o;
4864     }
4865
4866     tbl = (short*)PerlMemShared_calloc(
4867         (o->op_private & OPpTRANS_COMPLEMENT) &&
4868             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4869         sizeof(short));
4870     cPVOPo->op_pv = (char*)tbl;
4871     if (complement) {
4872         for (i = 0; i < (I32)tlen; i++)
4873             tbl[t[i]] = -1;
4874         for (i = 0, j = 0; i < 256; i++) {
4875             if (!tbl[i]) {
4876                 if (j >= (I32)rlen) {
4877                     if (del)
4878                         tbl[i] = -2;
4879                     else if (rlen)
4880                         tbl[i] = r[j-1];
4881                     else
4882                         tbl[i] = (short)i;
4883                 }
4884                 else {
4885                     if (i < 128 && r[j] >= 128)
4886                         grows = 1;
4887                     tbl[i] = r[j++];
4888                 }
4889             }
4890         }
4891         if (!del) {
4892             if (!rlen) {
4893                 j = rlen;
4894                 if (!squash)
4895                     o->op_private |= OPpTRANS_IDENTICAL;
4896             }
4897             else if (j >= (I32)rlen)
4898                 j = rlen - 1;
4899             else {
4900                 tbl = 
4901                     (short *)
4902                     PerlMemShared_realloc(tbl,
4903                                           (0x101+rlen-j) * sizeof(short));
4904                 cPVOPo->op_pv = (char*)tbl;
4905             }
4906             tbl[0x100] = (short)(rlen - j);
4907             for (i=0; i < (I32)rlen - j; i++)
4908                 tbl[0x101+i] = r[j+i];
4909         }
4910     }
4911     else {
4912         if (!rlen && !del) {
4913             r = t; rlen = tlen;
4914             if (!squash)
4915                 o->op_private |= OPpTRANS_IDENTICAL;
4916         }
4917         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4918             o->op_private |= OPpTRANS_IDENTICAL;
4919         }
4920         for (i = 0; i < 256; i++)
4921             tbl[i] = -1;
4922         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4923             if (j >= (I32)rlen) {
4924                 if (del) {
4925                     if (tbl[t[i]] == -1)
4926                         tbl[t[i]] = -2;
4927                     continue;
4928                 }
4929                 --j;
4930             }
4931             if (tbl[t[i]] == -1) {
4932                 if (t[i] < 128 && r[j] >= 128)
4933                     grows = 1;
4934                 tbl[t[i]] = r[j];
4935             }
4936         }
4937     }
4938
4939     if(del && rlen == tlen) {
4940         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
4941     } else if(rlen > tlen && !complement) {
4942         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4943     }
4944
4945     if (grows)
4946         o->op_private |= OPpTRANS_GROWS;
4947     op_free(expr);
4948     op_free(repl);
4949
4950     return o;
4951 }
4952
4953 /*
4954 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4955
4956 Constructs, checks, and returns an op of any pattern matching type.
4957 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4958 and, shifted up eight bits, the eight bits of C<op_private>.
4959
4960 =cut
4961 */
4962
4963 OP *
4964 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4965 {
4966     dVAR;
4967     PMOP *pmop;
4968
4969     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4970
4971     NewOp(1101, pmop, 1, PMOP);
4972     pmop->op_type = (OPCODE)type;
4973     pmop->op_ppaddr = PL_ppaddr[type];
4974     pmop->op_flags = (U8)flags;
4975     pmop->op_private = (U8)(0 | (flags >> 8));
4976
4977     if (PL_hints & HINT_RE_TAINT)
4978         pmop->op_pmflags |= PMf_RETAINT;
4979 #ifdef USE_LOCALE_CTYPE
4980     if (IN_LC_COMPILETIME(LC_CTYPE)) {
4981         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4982     }
4983     else
4984 #endif
4985          if (IN_UNI_8_BIT) {
4986         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4987     }
4988     if (PL_hints & HINT_RE_FLAGS) {
4989         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4990          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4991         );
4992         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4993         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4994          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4995         );
4996         if (reflags && SvOK(reflags)) {
4997             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4998         }
4999     }
5000
5001
5002 #ifdef USE_ITHREADS
5003     assert(SvPOK(PL_regex_pad[0]));
5004     if (SvCUR(PL_regex_pad[0])) {
5005         /* Pop off the "packed" IV from the end.  */
5006         SV *const repointer_list = PL_regex_pad[0];
5007         const char *p = SvEND(repointer_list) - sizeof(IV);
5008         const IV offset = *((IV*)p);
5009
5010         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
5011
5012         SvEND_set(repointer_list, p);
5013
5014         pmop->op_pmoffset = offset;
5015         /* This slot should be free, so assert this:  */
5016         assert(PL_regex_pad[offset] == &PL_sv_undef);
5017     } else {
5018         SV * const repointer = &PL_sv_undef;
5019         av_push(PL_regex_padav, repointer);
5020         pmop->op_pmoffset = av_tindex(PL_regex_padav);
5021         PL_regex_pad = AvARRAY(PL_regex_padav);
5022     }
5023 #endif
5024
5025     return CHECKOP(type, pmop);
5026 }
5027
5028 /* Given some sort of match op o, and an expression expr containing a
5029  * pattern, either compile expr into a regex and attach it to o (if it's
5030  * constant), or convert expr into a runtime regcomp op sequence (if it's
5031  * not)
5032  *
5033  * isreg indicates that the pattern is part of a regex construct, eg
5034  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
5035  * split "pattern", which aren't. In the former case, expr will be a list
5036  * if the pattern contains more than one term (eg /a$b/) or if it contains
5037  * a replacement, ie s/// or tr///.
5038  *
5039  * When the pattern has been compiled within a new anon CV (for
5040  * qr/(?{...})/ ), then floor indicates the savestack level just before
5041  * the new sub was created
5042  */
5043
5044 OP *
5045 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
5046 {
5047     dVAR;
5048     PMOP *pm;
5049     LOGOP *rcop;
5050     I32 repl_has_vars = 0;
5051     OP* repl = NULL;
5052     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
5053     bool is_compiletime;
5054     bool has_code;
5055
5056     PERL_ARGS_ASSERT_PMRUNTIME;
5057
5058     /* for s/// and tr///, last element in list is the replacement; pop it */
5059
5060     if (is_trans || o->op_type == OP_SUBST) {
5061         OP* kid;
5062         repl = cLISTOPx(expr)->op_last;
5063         kid = cLISTOPx(expr)->op_first;
5064         while (OP_SIBLING(kid) != repl)
5065             kid = OP_SIBLING(kid);
5066         op_sibling_splice(expr, kid, 1, NULL);
5067     }
5068
5069     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
5070
5071     if (is_trans) {
5072         OP *first, *last;
5073
5074         assert(expr->op_type == OP_LIST);
5075         first = cLISTOPx(expr)->op_first;
5076         last  = cLISTOPx(expr)->op_last;
5077         assert(first->op_type == OP_PUSHMARK);
5078         assert(OP_SIBLING(first) == last);
5079
5080         /* cut 'last' from sibling chain, then free everything else */
5081         op_sibling_splice(expr, first, 1, NULL);
5082         op_free(expr);
5083
5084         return pmtrans(o, last, repl);
5085     }
5086
5087     /* find whether we have any runtime or code elements;
5088      * at the same time, temporarily set the op_next of each DO block;
5089      * then when we LINKLIST, this will cause the DO blocks to be excluded
5090      * from the op_next chain (and from having LINKLIST recursively
5091      * applied to them). We fix up the DOs specially later */
5092
5093     is_compiletime = 1;
5094     has_code = 0;
5095     if (expr->op_type == OP_LIST) {
5096         OP *o;
5097         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5098             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5099                 has_code = 1;
5100                 assert(!o->op_next);
5101                 if (UNLIKELY(!OP_HAS_SIBLING(o))) {
5102                     assert(PL_parser && PL_parser->error_count);
5103                     /* This can happen with qr/ (?{(^{})/.  Just fake up
5104                        the op we were expecting to see, to avoid crashing
5105                        elsewhere.  */
5106                     op_sibling_splice(expr, o, 0,
5107                                       newSVOP(OP_CONST, 0, &PL_sv_no));
5108                 }
5109                 o->op_next = OP_SIBLING(o);
5110             }
5111             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
5112                 is_compiletime = 0;
5113         }
5114     }
5115     else if (expr->op_type != OP_CONST)
5116         is_compiletime = 0;
5117
5118     LINKLIST(expr);
5119
5120     /* fix up DO blocks; treat each one as a separate little sub;
5121      * also, mark any arrays as LIST/REF */
5122
5123     if (expr->op_type == OP_LIST) {
5124         OP *o;
5125         for (o = cLISTOPx(expr)->op_first; o; o = OP_SIBLING(o)) {
5126
5127             if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
5128                 assert( !(o->op_flags  & OPf_WANT));
5129                 /* push the array rather than its contents. The regex
5130                  * engine will retrieve and join the elements later */
5131                 o->op_flags |= (OPf_WANT_LIST | OPf_REF);
5132                 continue;
5133             }
5134
5135             if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
5136                 continue;
5137             o->op_next = NULL; /* undo temporary hack from above */
5138             scalar(o);
5139             LINKLIST(o);
5140             if (cLISTOPo->op_first->op_type == OP_LEAVE) {
5141                 LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
5142                 /* skip ENTER */
5143                 assert(leaveop->op_first->op_type == OP_ENTER);
5144                 assert(OP_HAS_SIBLING(leaveop->op_first));
5145                 o->op_next = OP_SIBLING(leaveop->op_first);
5146                 /* skip leave */
5147                 assert(leaveop->op_flags & OPf_KIDS);
5148                 assert(leaveop->op_last->op_next == (OP*)leaveop);
5149                 leaveop->op_next = NULL; /* stop on last op */
5150                 op_null((OP*)leaveop);
5151             }
5152             else {
5153                 /* skip SCOPE */
5154                 OP *scope = cLISTOPo->op_first;
5155                 assert(scope->op_type == OP_SCOPE);
5156                 assert(scope->op_flags & OPf_KIDS);
5157                 scope->op_next = NULL; /* stop on last op */
5158                 op_null(scope);
5159             }
5160             /* have to peep the DOs individually as we've removed it from
5161              * the op_next chain */
5162             CALL_PEEP(o);
5163             S_prune_chain_head(&(o->op_next));
5164             if (is_compiletime)
5165                 /* runtime finalizes as part of finalizing whole tree */
5166                 finalize_optree(o);
5167         }
5168     }
5169     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
5170         assert( !(expr->op_flags  & OPf_WANT));
5171         /* push the array rather than its contents. The regex
5172          * engine will retrieve and join the elements later */
5173         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
5174     }
5175
5176     PL_hints |= HINT_BLOCK_SCOPE;
5177     pm = (PMOP*)o;
5178     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
5179
5180     if (is_compiletime) {
5181         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
5182         regexp_engine const *eng = current_re_engine();
5183
5184         if (o->op_flags & OPf_SPECIAL)
5185             rx_flags |= RXf_SPLIT;
5186
5187         if (!has_code || !eng->op_comp) {
5188             /* compile-time simple constant pattern */
5189
5190             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
5191                 /* whoops! we guessed that a qr// had a code block, but we
5192                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
5193                  * that isn't required now. Note that we have to be pretty
5194                  * confident that nothing used that CV's pad while the
5195                  * regex was parsed */
5196                 assert(AvFILLp(PL_comppad) == 0); /* just @_ */
5197                 /* But we know that one op is using this CV's slab. */
5198                 cv_forget_slab(PL_compcv);
5199                 LEAVE_SCOPE(floor);
5200                 pm->op_pmflags &= ~PMf_HAS_CV;
5201             }
5202
5203             PM_SETRE(pm,
5204                 eng->op_comp
5205                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5206                                         rx_flags, pm->op_pmflags)
5207                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5208                                         rx_flags, pm->op_pmflags)
5209             );
5210             op_free(expr);
5211         }
5212         else {
5213             /* compile-time pattern that includes literal code blocks */
5214             REGEXP* re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
5215                         rx_flags,
5216                         (pm->op_pmflags |
5217                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
5218                     );
5219             PM_SETRE(pm, re);
5220             if (pm->op_pmflags & PMf_HAS_CV) {
5221                 CV *cv;
5222                 /* this QR op (and the anon sub we embed it in) is never
5223                  * actually executed. It's just a placeholder where we can
5224                  * squirrel away expr in op_code_list without the peephole
5225                  * optimiser etc processing it for a second time */
5226                 OP *qr = newPMOP(OP_QR, 0);
5227                 ((PMOP*)qr)->op_code_list = expr;
5228
5229                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
5230                 SvREFCNT_inc_simple_void(PL_compcv);
5231                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
5232                 ReANY(re)->qr_anoncv = cv;
5233
5234                 /* attach the anon CV to the pad so that
5235                  * pad_fixup_inner_anons() can find it */
5236                 (void)pad_add_anon(cv, o->op_type);
5237                 SvREFCNT_inc_simple_void(cv);
5238             }
5239             else {
5240                 pm->op_code_list = expr;
5241             }
5242         }
5243     }
5244     else {
5245         /* runtime pattern: build chain of regcomp etc ops */
5246         bool reglist;
5247         PADOFFSET cv_targ = 0;
5248
5249         reglist = isreg && expr->op_type == OP_LIST;
5250         if (reglist)
5251             op_null(expr);
5252
5253         if (has_code) {
5254             pm->op_code_list = expr;
5255             /* don't free op_code_list; its ops are embedded elsewhere too */
5256             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
5257         }
5258
5259         if (o->op_flags & OPf_SPECIAL)
5260             pm->op_pmflags |= PMf_SPLIT;
5261
5262         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
5263          * to allow its op_next to be pointed past the regcomp and
5264          * preceding stacking ops;
5265          * OP_REGCRESET is there to reset taint before executing the
5266          * stacking ops */
5267         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
5268             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
5269
5270         if (pm->op_pmflags & PMf_HAS_CV) {
5271             /* we have a runtime qr with literal code. This means
5272              * that the qr// has been wrapped in a new CV, which
5273              * means that runtime consts, vars etc will have been compiled
5274              * against a new pad. So... we need to execute those ops
5275              * within the environment of the new CV. So wrap them in a call
5276              * to a new anon sub. i.e. for
5277              *
5278              *     qr/a$b(?{...})/,
5279              *
5280              * we build an anon sub that looks like
5281              *
5282              *     sub { "a", $b, '(?{...})' }
5283              *
5284              * and call it, passing the returned list to regcomp.
5285              * Or to put it another way, the list of ops that get executed
5286              * are:
5287              *
5288              *     normal              PMf_HAS_CV
5289              *     ------              -------------------
5290              *                         pushmark (for regcomp)
5291              *                         pushmark (for entersub)
5292              *                         anoncode
5293              *                         srefgen
5294              *                         entersub
5295              *     regcreset                  regcreset
5296              *     pushmark                   pushmark
5297              *     const("a")                 const("a")
5298              *     gvsv(b)                    gvsv(b)
5299              *     const("(?{...})")          const("(?{...})")
5300              *                                leavesub
5301              *     regcomp             regcomp
5302              */
5303
5304             SvREFCNT_inc_simple_void(PL_compcv);
5305             /* these lines are just an unrolled newANONATTRSUB */
5306             expr = newSVOP(OP_ANONCODE, 0,
5307                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
5308             cv_targ = expr->op_targ;
5309             expr = newUNOP(OP_REFGEN, 0, expr);
5310
5311             expr = list(force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr)), 1));
5312         }
5313
5314         rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
5315         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
5316         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
5317                            | (reglist ? OPf_STACKED : 0);
5318         rcop->op_targ = cv_targ;
5319
5320         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
5321         if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
5322
5323         /* establish postfix order */
5324         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
5325             LINKLIST(expr);
5326             rcop->op_next = expr;
5327             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
5328         }
5329         else {
5330             rcop->op_next = LINKLIST(expr);
5331             expr->op_next = (OP*)rcop;
5332         }
5333
5334         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
5335     }
5336
5337     if (repl) {
5338         OP *curop = repl;
5339         bool konst;
5340         /* If we are looking at s//.../e with a single statement, get past
5341            the implicit do{}. */
5342         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
5343              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
5344              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
5345          {
5346             OP *sib;
5347             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
5348             if (kid->op_type == OP_NULL && (sib = OP_SIBLING(kid))
5349                      && !OP_HAS_SIBLING(sib))
5350                 curop = sib;
5351         }
5352         if (curop->op_type == OP_CONST)
5353             konst = TRUE;
5354         else if (( (curop->op_type == OP_RV2SV ||
5355                     curop->op_type == OP_RV2AV ||
5356                     curop->op_type == OP_RV2HV ||
5357                     curop->op_type == OP_RV2GV)
5358                    && cUNOPx(curop)->op_first
5359                    && cUNOPx(curop)->op_first->op_type == OP_GV )
5360                 || curop->op_type == OP_PADSV
5361                 || curop->op_type == OP_PADAV
5362                 || curop->op_type == OP_PADHV
5363                 || curop->op_type == OP_PADANY) {
5364             repl_has_vars = 1;
5365             konst = TRUE;
5366         }
5367         else konst = FALSE;
5368         if (konst
5369             && !(repl_has_vars
5370                  && (!PM_GETRE(pm)
5371                      || !RX_PRELEN(PM_GETRE(pm))
5372                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
5373         {
5374             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
5375             op_prepend_elem(o->op_type, scalar(repl), o);
5376         }
5377         else {
5378             rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
5379             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
5380             rcop->op_private = 1;
5381
5382             /* establish postfix order */
5383             rcop->op_next = LINKLIST(repl);
5384             repl->op_next = (OP*)rcop;
5385
5386             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
5387             assert(!(pm->op_pmflags & PMf_ONCE));
5388             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
5389             rcop->op_next = 0;
5390         }
5391     }
5392
5393     return (OP*)pm;
5394 }
5395
5396 /*
5397 =for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
5398
5399 Constructs, checks, and returns an op of any type that involves an
5400 embedded SV.  I<type> is the opcode.  I<flags> gives the eight bits
5401 of C<op_flags>.  I<sv> gives the SV to embed in the op; this function
5402 takes ownership of one reference to it.
5403
5404 =cut
5405 */
5406
5407 OP *
5408 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
5409 {
5410     dVAR;
5411     SVOP *svop;
5412
5413     PERL_ARGS_ASSERT_NEWSVOP;
5414
5415     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5416         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5417         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5418
5419     NewOp(1101, svop, 1, SVOP);
5420     svop->op_type = (OPCODE)type;
5421     svop->op_ppaddr = PL_ppaddr[type];
5422     svop->op_sv = sv;
5423     svop->op_next = (OP*)svop;
5424     svop->op_flags = (U8)flags;
5425     svop->op_private = (U8)(0 | (flags >> 8));
5426     if (PL_opargs[type] & OA_RETSCALAR)
5427         scalar((OP*)svop);
5428     if (PL_opargs[type] & OA_TARGET)
5429         svop->op_targ = pad_alloc(type, SVs_PADTMP);
5430     return CHECKOP(type, svop);
5431 }
5432
5433 #ifdef USE_ITHREADS
5434
5435 /*
5436 =for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
5437
5438 Constructs, checks, and returns an op of any type that involves a
5439 reference to a pad element.  I<type> is the opcode.  I<flags> gives the
5440 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
5441 is populated with I<sv>; this function takes ownership of one reference
5442 to it.
5443
5444 This function only exists if Perl has been compiled to use ithreads.
5445
5446 =cut
5447 */
5448
5449 OP *
5450 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
5451 {
5452     dVAR;
5453     PADOP *padop;
5454
5455     PERL_ARGS_ASSERT_NEWPADOP;
5456
5457     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
5458         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5459         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
5460
5461     NewOp(1101, padop, 1, PADOP);
5462     padop->op_type = (OPCODE)type;
5463     padop->op_ppaddr = PL_ppaddr[type];
5464     padop->op_padix =
5465         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
5466     SvREFCNT_dec(PAD_SVl(padop->op_padix));
5467     PAD_SETSV(padop->op_padix, sv);
5468     assert(sv);
5469     padop->op_next = (OP*)padop;
5470     padop->op_flags = (U8)flags;
5471     if (PL_opargs[type] & OA_RETSCALAR)
5472         scalar((OP*)padop);
5473     if (PL_opargs[type] & OA_TARGET)
5474         padop->op_targ = pad_alloc(type, SVs_PADTMP);
5475     return CHECKOP(type, padop);
5476 }
5477
5478 #endif /* USE_ITHREADS */
5479
5480 /*
5481 =for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
5482
5483 Constructs, checks, and returns an op of any type that involves an
5484 embedded reference to a GV.  I<type> is the opcode.  I<flags> gives the
5485 eight bits of C<op_flags>.  I<gv> identifies the GV that the op should
5486 reference; calling this function does not transfer ownership of any
5487 reference to it.
5488
5489 =cut
5490 */
5491
5492 OP *
5493 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
5494 {
5495     PERL_ARGS_ASSERT_NEWGVOP;
5496
5497 #ifdef USE_ITHREADS
5498     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5499 #else
5500     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
5501 #endif
5502 }
5503
5504 /*
5505 =for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
5506
5507 Constructs, checks, and returns an op of any type that involves an
5508 embedded C-level pointer (PV).  I<type> is the opcode.  I<flags> gives
5509 the eight bits of C<op_flags>.  I<pv> supplies the C-level pointer, which
5510 must have been allocated using C<PerlMemShared_malloc>; the memory will
5511 be freed when the op is destroyed.
5512
5513 =cut
5514 */
5515
5516 OP *
5517 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
5518 {
5519     dVAR;
5520     const bool utf8 = cBOOL(flags & SVf_UTF8);
5521     PVOP *pvop;
5522
5523     flags &= ~SVf_UTF8;
5524
5525     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
5526         || type == OP_RUNCV
5527         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5528
5529     NewOp(1101, pvop, 1, PVOP);
5530     pvop->op_type = (OPCODE)type;
5531     pvop->op_ppaddr = PL_ppaddr[type];
5532     pvop->op_pv = pv;
5533     pvop->op_next = (OP*)pvop;
5534     pvop->op_flags = (U8)flags;
5535     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
5536     if (PL_opargs[type] & OA_RETSCALAR)
5537         scalar((OP*)pvop);
5538     if (PL_opargs[type] & OA_TARGET)
5539         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
5540     return CHECKOP(type, pvop);
5541 }
5542
5543 void
5544 Perl_package(pTHX_ OP *o)
5545 {
5546     SV *const sv = cSVOPo->op_sv;
5547
5548     PERL_ARGS_ASSERT_PACKAGE;
5549
5550     SAVEGENERICSV(PL_curstash);
5551     save_item(PL_curstname);
5552
5553     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
5554
5555     sv_setsv(PL_curstname, sv);
5556
5557     PL_hints |= HINT_BLOCK_SCOPE;
5558     PL_parser->copline = NOLINE;
5559
5560     op_free(o);
5561 }
5562
5563 void
5564 Perl_package_version( pTHX_ OP *v )
5565 {
5566     U32 savehints = PL_hints;
5567     PERL_ARGS_ASSERT_PACKAGE_VERSION;
5568     PL_hints &= ~HINT_STRICT_VARS;
5569     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
5570     PL_hints = savehints;
5571     op_free(v);
5572 }
5573
5574 void
5575 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
5576 {
5577     OP *pack;
5578     OP *imop;
5579     OP *veop;
5580     SV *use_version = NULL;
5581
5582     PERL_ARGS_ASSERT_UTILIZE;
5583
5584     if (idop->op_type != OP_CONST)
5585         Perl_croak(aTHX_ "Module name must be constant");
5586
5587     veop = NULL;
5588
5589     if (version) {
5590         SV * const vesv = ((SVOP*)version)->op_sv;
5591
5592         if (!arg && !SvNIOKp(vesv)) {
5593             arg = version;
5594         }
5595         else {
5596             OP *pack;
5597             SV *meth;
5598
5599             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
5600                 Perl_croak(aTHX_ "Version number must be a constant number");
5601
5602             /* Make copy of idop so we don't free it twice */
5603             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5604
5605             /* Fake up a method call to VERSION */
5606             meth = newSVpvs_share("VERSION");
5607             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5608                             op_append_elem(OP_LIST,
5609                                         op_prepend_elem(OP_LIST, pack, version),
5610                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
5611         }
5612     }
5613
5614     /* Fake up an import/unimport */
5615     if (arg && arg->op_type == OP_STUB) {
5616         imop = arg;             /* no import on explicit () */
5617     }
5618     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
5619         imop = NULL;            /* use 5.0; */
5620         if (aver)
5621             use_version = ((SVOP*)idop)->op_sv;
5622         else
5623             idop->op_private |= OPpCONST_NOVER;
5624     }
5625     else {
5626         SV *meth;
5627
5628         /* Make copy of idop so we don't free it twice */
5629         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
5630
5631         /* Fake up a method call to import/unimport */
5632         meth = aver
5633             ? newSVpvs_share("import") : newSVpvs_share("unimport");
5634         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
5635                        op_append_elem(OP_LIST,
5636                                    op_prepend_elem(OP_LIST, pack, arg),
5637                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
5638                        ));
5639     }
5640
5641     /* Fake up the BEGIN {}, which does its thing immediately. */
5642     newATTRSUB(floor,
5643         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
5644         NULL,
5645         NULL,
5646         op_append_elem(OP_LINESEQ,
5647             op_append_elem(OP_LINESEQ,
5648                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
5649                 newSTATEOP(0, NULL, veop)),
5650             newSTATEOP(0, NULL, imop) ));
5651
5652     if (use_version) {
5653         /* Enable the
5654          * feature bundle that corresponds to the required version. */
5655         use_version = sv_2mortal(new_version(use_version));
5656         S_enable_feature_bundle(aTHX_ use_version);
5657
5658         /* If a version >= 5.11.0 is requested, strictures are on by default! */
5659         if (vcmp(use_version,
5660                  sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
5661             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5662                 PL_hints |= HINT_STRICT_REFS;
5663             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5664                 PL_hints |= HINT_STRICT_SUBS;
5665             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5666                 PL_hints |= HINT_STRICT_VARS;
5667         }
5668         /* otherwise they are off */
5669         else {
5670             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
5671                 PL_hints &= ~HINT_STRICT_REFS;
5672             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
5673                 PL_hints &= ~HINT_STRICT_SUBS;
5674             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
5675                 PL_hints &= ~HINT_STRICT_VARS;
5676         }
5677     }
5678
5679     /* The "did you use incorrect case?" warning used to be here.
5680      * The problem is that on case-insensitive filesystems one
5681      * might get false positives for "use" (and "require"):
5682      * "use Strict" or "require CARP" will work.  This causes
5683      * portability problems for the script: in case-strict
5684      * filesystems the script will stop working.
5685      *
5686      * The "incorrect case" warning checked whether "use Foo"
5687      * imported "Foo" to your namespace, but that is wrong, too:
5688      * there is no requirement nor promise in the language that
5689      * a Foo.pm should or would contain anything in package "Foo".
5690      *
5691      * There is very little Configure-wise that can be done, either:
5692      * the case-sensitivity of the build filesystem of Perl does not
5693      * help in guessing the case-sensitivity of the runtime environment.
5694      */
5695
5696     PL_hints |= HINT_BLOCK_SCOPE;
5697     PL_parser->copline = NOLINE;
5698     PL_cop_seqmax++; /* Purely for B::*'s benefit */
5699     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
5700         PL_cop_seqmax++;
5701
5702 }
5703
5704 /*
5705 =head1 Embedding Functions
5706
5707 =for apidoc load_module
5708
5709 Loads the module whose name is pointed to by the string part of name.
5710 Note that the actual module name, not its filename, should be given.
5711 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
5712 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
5713 (or 0 for no flags).  ver, if specified
5714 and not NULL, provides version semantics
5715 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
5716 arguments can be used to specify arguments to the module's import()
5717 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
5718 terminated with a final NULL pointer.  Note that this list can only
5719 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
5720 Otherwise at least a single NULL pointer to designate the default
5721 import list is required.
5722
5723 The reference count for each specified C<SV*> parameter is decremented.
5724
5725 =cut */
5726
5727 void
5728 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
5729 {
5730     va_list args;
5731
5732     PERL_ARGS_ASSERT_LOAD_MODULE;
5733
5734     va_start(args, ver);
5735     vload_module(flags, name, ver, &args);
5736     va_end(args);
5737 }
5738
5739 #ifdef PERL_IMPLICIT_CONTEXT
5740 void
5741 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
5742 {
5743     dTHX;
5744     va_list args;
5745     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
5746     va_start(args, ver);
5747     vload_module(flags, name, ver, &args);
5748     va_end(args);
5749 }
5750 #endif
5751
5752 void
5753 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
5754 {
5755     OP *veop, *imop;
5756     OP * const modname = newSVOP(OP_CONST, 0, name);
5757
5758     PERL_ARGS_ASSERT_VLOAD_MODULE;
5759
5760     modname->op_private |= OPpCONST_BARE;
5761     if (ver) {
5762         veop = newSVOP(OP_CONST, 0, ver);
5763     }
5764     else
5765         veop = NULL;
5766     if (flags & PERL_LOADMOD_NOIMPORT) {
5767         imop = sawparens(newNULLLIST());
5768     }
5769     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
5770         imop = va_arg(*args, OP*);
5771     }
5772     else {
5773         SV *sv;
5774         imop = NULL;
5775         sv = va_arg(*args, SV*);
5776         while (sv) {
5777             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
5778             sv = va_arg(*args, SV*);
5779         }
5780     }
5781
5782     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
5783      * that it has a PL_parser to play with while doing that, and also
5784      * that it doesn't mess with any existing parser, by creating a tmp
5785      * new parser with lex_start(). This won't actually be used for much,
5786      * since pp_require() will create another parser for the real work.
5787      * The ENTER/LEAVE pair protect callers from any side effects of use.  */
5788
5789     ENTER;
5790     SAVEVPTR(PL_curcop);
5791     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
5792     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
5793             veop, modname, imop);
5794     LEAVE;
5795 }
5796
5797 PERL_STATIC_INLINE OP *
5798 S_new_entersubop(pTHX_ GV *gv, OP *arg)
5799 {
5800     return newUNOP(OP_ENTERSUB, OPf_STACKED,
5801                    newLISTOP(OP_LIST, 0, arg,
5802                              newUNOP(OP_RV2CV, 0,
5803                                      newGVOP(OP_GV, 0, gv))));
5804 }
5805
5806 OP *
5807 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
5808 {
5809     OP *doop;
5810     GV *gv;
5811
5812     PERL_ARGS_ASSERT_DOFILE;
5813
5814     if (!force_builtin && (gv = gv_override("do", 2))) {
5815         doop = S_new_entersubop(aTHX_ gv, term);
5816     }
5817     else {
5818         doop = newUNOP(OP_DOFILE, 0, scalar(term));
5819     }
5820     return doop;
5821 }
5822
5823 /*
5824 =head1 Optree construction
5825
5826 =for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
5827
5828 Constructs, checks, and returns an C<lslice> (list slice) op.  I<flags>
5829 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
5830 be set automatically, and, shifted up eight bits, the eight bits of
5831 C<op_private>, except that the bit with value 1 or 2 is automatically
5832 set as required.  I<listval> and I<subscript> supply the parameters of
5833 the slice; they are consumed by this function and become part of the
5834 constructed op tree.
5835
5836 =cut
5837 */
5838
5839 OP *
5840 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
5841 {
5842     return newBINOP(OP_LSLICE, flags,
5843             list(force_list(subscript, 1)),
5844             list(force_list(listval,   1)) );
5845 }
5846
5847 #define ASSIGN_LIST   1
5848 #define ASSIGN_REF    2
5849
5850 STATIC I32
5851 S_assignment_type(pTHX_ const OP *o)
5852 {
5853     unsigned type;
5854     U8 flags;
5855     U8 ret;
5856
5857     if (!o)
5858         return TRUE;
5859
5860     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
5861         o = cUNOPo->op_first;
5862
5863     flags = o->op_flags;
5864     type = o->op_type;
5865     if (type == OP_COND_EXPR) {
5866         OP * const sib = OP_SIBLING(cLOGOPo->op_first);
5867         const I32 t = assignment_type(sib);
5868         const I32 f = assignment_type(OP_SIBLING(sib));
5869
5870         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
5871             return ASSIGN_LIST;
5872         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
5873             yyerror("Assignment to both a list and a scalar");
5874         return FALSE;
5875     }
5876
5877     if (type == OP_SREFGEN)
5878     {
5879         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
5880         type = kid->op_type;
5881         flags |= kid->op_flags;
5882         if (!(flags & OPf_PARENS)
5883           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
5884               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
5885             return ASSIGN_REF;
5886         ret = ASSIGN_REF;
5887     }
5888     else ret = 0;
5889
5890     if (type == OP_LIST &&
5891         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
5892         o->op_private & OPpLVAL_INTRO)
5893         return ret;
5894
5895     if (type == OP_LIST || flags & OPf_PARENS ||
5896         type == OP_RV2AV || type == OP_RV2HV ||
5897         type == OP_ASLICE || type == OP_HSLICE ||
5898         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
5899         return TRUE;
5900
5901     if (type == OP_PADAV || type == OP_PADHV)
5902         return TRUE;
5903
5904     if (type == OP_RV2SV)
5905         return ret;
5906
5907     return ret;
5908 }
5909
5910 /*
5911   Helper function for newASSIGNOP to detection commonality between the
5912   lhs and the rhs.  (It is actually called very indirectly.  newASSIGNOP
5913   flags the op and the peephole optimizer calls this helper function
5914   if the flag is set.)  Marks all variables with PL_generation.  If it
5915   returns TRUE the assignment must be able to handle common variables.
5916
5917   PL_generation sorcery:
5918   An assignment like ($a,$b) = ($c,$d) is easier than
5919   ($a,$b) = ($c,$a), since there is no need for temporary vars.
5920   To detect whether there are common vars, the global var
5921   PL_generation is incremented for each assign op we compile.
5922   Then, while compiling the assign op, we run through all the
5923   variables on both sides of the assignment, setting a spare slot
5924   in each of them to PL_generation.  If any of them already have
5925   that value, we know we've got commonality.  Also, if the
5926   generation number is already set to PERL_INT_MAX, then
5927   the variable is involved in aliasing, so we also have
5928   potential commonality in that case.  We could use a
5929   single bit marker, but then we'd have to make 2 passes, first
5930   to clear the flag, then to test and set it.  And that
5931   wouldn't help with aliasing, either.  To find somewhere
5932   to store these values, evil chicanery is done with SvUVX().
5933 */
5934 PERL_STATIC_INLINE bool
5935 S_aassign_common_vars(pTHX_ OP* o)
5936 {
5937     OP *curop;
5938     for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
5939         if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
5940             if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
5941              || curop->op_type == OP_AELEMFAST) {
5942                 GV *gv = cGVOPx_gv(curop);
5943                 if (gv == PL_defgv
5944                     || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5945                     return TRUE;
5946                 GvASSIGN_GENERATION_set(gv, PL_generation);
5947             }
5948             else if (curop->op_type == OP_PADSV ||
5949                 curop->op_type == OP_PADAV ||
5950                 curop->op_type == OP_PADHV ||
5951                 curop->op_type == OP_AELEMFAST_LEX ||
5952                 curop->op_type == OP_PADANY)
5953                 {
5954                   padcheck:
5955                     if (PAD_COMPNAME_GEN(curop->op_targ)
5956                         == (STRLEN)PL_generation
5957                      || PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
5958                         return TRUE;
5959                     PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
5960
5961                 }
5962             else if (curop->op_type == OP_RV2CV)
5963                 return TRUE;
5964             else if (curop->op_type == OP_RV2SV ||
5965                 curop->op_type == OP_RV2AV ||
5966                 curop->op_type == OP_RV2HV ||
5967                 curop->op_type == OP_RV2GV) {
5968                 if (cUNOPx(curop)->op_first->op_type != OP_GV)  /* funny deref? */
5969                     return TRUE;
5970             }
5971             else if (curop->op_type == OP_PUSHRE) {
5972                 GV *const gv =
5973 #ifdef USE_ITHREADS
5974                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
5975                         ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
5976                         : NULL;
5977 #else
5978                     ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
5979 #endif
5980                 if (gv) {
5981                     if (gv == PL_defgv
5982                         || (int)GvASSIGN_GENERATION(gv) == PL_generation)
5983                         return TRUE;
5984                     GvASSIGN_GENERATION_set(gv, PL_generation);
5985                 }
5986                 else if (curop->op_targ)
5987                     goto padcheck;
5988             }
5989             else if (curop->op_type == OP_PADRANGE)
5990                 /* Ignore padrange; checking its siblings is sufficient. */
5991                 continue;
5992             else
5993                 return TRUE;
5994         }
5995         else if (PL_opargs[curop->op_type] & OA_TARGLEX
5996               && curop->op_private & OPpTARGET_MY)
5997             goto padcheck;
5998
5999         if (curop->op_flags & OPf_KIDS) {
6000             if (aassign_common_vars(curop))
6001                 return TRUE;
6002         }
6003     }
6004     return FALSE;
6005 }
6006
6007 /* This variant only handles lexical aliases.  It is called when
6008    newASSIGNOP decides that we don’t have any common vars, as lexical ali-
6009    ases trump that decision.  */
6010 PERL_STATIC_INLINE bool
6011 S_aassign_common_vars_aliases_only(pTHX_ OP *o)
6012 {
6013     OP *curop;
6014     for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
6015         if ((curop->op_type == OP_PADSV ||
6016              curop->op_type == OP_PADAV ||
6017              curop->op_type == OP_PADHV ||
6018              curop->op_type == OP_AELEMFAST_LEX ||
6019              curop->op_type == OP_PADANY ||
6020              (  PL_opargs[curop->op_type] & OA_TARGLEX
6021              && curop->op_private & OPpTARGET_MY  ))
6022            && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6023             return TRUE;
6024
6025         if (curop->op_type == OP_PUSHRE && curop->op_targ
6026          && PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
6027             return TRUE;
6028
6029         if (curop->op_flags & OPf_KIDS) {
6030             if (S_aassign_common_vars_aliases_only(aTHX_ curop))
6031                 return TRUE;
6032         }
6033     }
6034     return FALSE;
6035 }
6036
6037 /*
6038 =for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
6039
6040 Constructs, checks, and returns an assignment op.  I<left> and I<right>
6041 supply the parameters of the assignment; they are consumed by this
6042 function and become part of the constructed op tree.
6043
6044 If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
6045 a suitable conditional optree is constructed.  If I<optype> is the opcode
6046 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
6047 performs the binary operation and assigns the result to the left argument.
6048 Either way, if I<optype> is non-zero then I<flags> has no effect.
6049
6050 If I<optype> is zero, then a plain scalar or list assignment is
6051 constructed.  Which type of assignment it is is automatically determined.
6052 I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6053 will be set automatically, and, shifted up eight bits, the eight bits
6054 of C<op_private>, except that the bit with value 1 or 2 is automatically
6055 set as required.
6056
6057 =cut
6058 */
6059
6060 OP *
6061 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
6062 {
6063     OP *o;
6064     I32 assign_type;
6065
6066     if (optype) {
6067         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
6068             return newLOGOP(optype, 0,
6069                 op_lvalue(scalar(left), optype),
6070                 newUNOP(OP_SASSIGN, 0, scalar(right)));
6071         }
6072         else {
6073             return newBINOP(optype, OPf_STACKED,
6074                 op_lvalue(scalar(left), optype), scalar(right));
6075         }
6076     }
6077
6078     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
6079         static const char no_list_state[] = "Initialization of state variables"
6080             " in list context currently forbidden";
6081         OP *curop;
6082         bool maybe_common_vars = TRUE;
6083
6084         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
6085             left->op_private &= ~ OPpSLICEWARNING;
6086
6087         PL_modcount = 0;
6088         left = op_lvalue(left, OP_AASSIGN);
6089         curop = list(force_list(left, 1));
6090         o = newBINOP(OP_AASSIGN, flags, list(force_list(right, 1)), curop);
6091         o->op_private = (U8)(0 | (flags >> 8));
6092
6093         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
6094         {
6095             OP* lop = ((LISTOP*)left)->op_first;
6096             maybe_common_vars = FALSE;
6097             while (lop) {
6098                 if (lop->op_type == OP_PADSV ||
6099                     lop->op_type == OP_PADAV ||
6100                     lop->op_type == OP_PADHV ||
6101                     lop->op_type == OP_PADANY) {
6102                     if (!(lop->op_private & OPpLVAL_INTRO))
6103                         maybe_common_vars = TRUE;
6104
6105                     if (lop->op_private & OPpPAD_STATE) {
6106                         if (left->op_private & OPpLVAL_INTRO) {
6107                             /* Each variable in state($a, $b, $c) = ... */
6108                         }
6109                         else {
6110                             /* Each state variable in
6111                                (state $a, my $b, our $c, $d, undef) = ... */
6112                         }
6113                         yyerror(no_list_state);
6114                     } else {
6115                         /* Each my variable in
6116                            (state $a, my $b, our $c, $d, undef) = ... */
6117                     }
6118                 } else if (lop->op_type == OP_UNDEF ||
6119                            OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) {
6120                     /* undef may be interesting in
6121                        (state $a, undef, state $c) */
6122                 } else {
6123                     /* Other ops in the list. */
6124                     maybe_common_vars = TRUE;
6125                 }
6126                 lop = OP_SIBLING(lop);
6127             }
6128         }
6129         else if ((left->op_private & OPpLVAL_INTRO)
6130                 && (   left->op_type == OP_PADSV
6131                     || left->op_type == OP_PADAV
6132                     || left->op_type == OP_PADHV
6133                     || left->op_type == OP_PADANY))
6134         {
6135             if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
6136             if (left->op_private & OPpPAD_STATE) {
6137                 /* All single variable list context state assignments, hence
6138                    state ($a) = ...
6139                    (state $a) = ...
6140                    state @a = ...
6141                    state (@a) = ...
6142                    (state @a) = ...
6143                    state %a = ...
6144                    state (%a) = ...
6145                    (state %a) = ...
6146                 */
6147                 yyerror(no_list_state);
6148             }
6149         }
6150
6151         if (maybe_common_vars) {
6152                 /* The peephole optimizer will do the full check and pos-
6153                    sibly turn this off.  */
6154                 o->op_private |= OPpASSIGN_COMMON;
6155         }
6156
6157         if (right && right->op_type == OP_SPLIT
6158          && !(right->op_flags & OPf_STACKED)) {
6159             OP* tmpop = ((LISTOP*)right)->op_first;
6160             PMOP * const pm = (PMOP*)tmpop;
6161             assert (tmpop && (tmpop->op_type == OP_PUSHRE));
6162             if (
6163 #ifdef USE_ITHREADS
6164                     !pm->op_pmreplrootu.op_pmtargetoff
6165 #else
6166                     !pm->op_pmreplrootu.op_pmtargetgv
6167 #endif
6168                  && !pm->op_targ
6169                 ) {
6170                     if (!(left->op_private & OPpLVAL_INTRO) &&
6171                         ( (left->op_type == OP_RV2AV &&
6172                           (tmpop=((UNOP*)left)->op_first)->op_type==OP_GV)
6173                         || left->op_type == OP_PADAV )
6174                         ) {
6175                         if (tmpop != (OP *)pm) {
6176 #ifdef USE_ITHREADS
6177                           pm->op_pmreplrootu.op_pmtargetoff
6178                             = cPADOPx(tmpop)->op_padix;
6179                           cPADOPx(tmpop)->op_padix = 0; /* steal it */
6180 #else
6181                           pm->op_pmreplrootu.op_pmtargetgv
6182                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
6183                           cSVOPx(tmpop)->op_sv = NULL;  /* steal it */
6184 #endif
6185                           right->op_private |=
6186                             left->op_private & OPpOUR_INTRO;
6187                         }
6188                         else {
6189                             pm->op_targ = left->op_targ;
6190                             left->op_targ = 0; /* filch it */
6191                         }
6192                       detach_split:
6193                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
6194                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
6195                         /* detach rest of siblings from o subtree,
6196                          * and free subtree */
6197                         op_sibling_splice(cUNOPo->op_first, tmpop, -1, NULL);
6198                         op_free(o);                     /* blow off assign */
6199                         right->op_flags &= ~OPf_WANT;
6200                                 /* "I don't know and I don't care." */
6201                         return right;
6202                     }
6203                     else if (left->op_type == OP_RV2AV
6204                           || left->op_type == OP_PADAV)
6205                     {
6206                         /* Detach the array.  */
6207 #ifdef DEBUGGING
6208                         OP * const ary =
6209 #endif
6210                         op_sibling_splice(cBINOPo->op_last,
6211                                           cUNOPx(cBINOPo->op_last)
6212                                                 ->op_first, 1, NULL);
6213                         assert(ary == left);
6214                         /* Attach it to the split.  */
6215                         op_sibling_splice(right, cLISTOPx(right)->op_last,
6216                                           0, left);
6217                         right->op_flags |= OPf_STACKED;
6218                         /* Detach split and expunge aassign as above.  */
6219                         goto detach_split;
6220                     }
6221                     else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
6222                             ((LISTOP*)right)->op_last->op_type == OP_CONST)
6223                     {
6224                         SV ** const svp =
6225                             &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
6226                         SV * const sv = *svp;
6227                         if (SvIOK(sv) && SvIVX(sv) == 0)
6228                         {
6229                           if (right->op_private & OPpSPLIT_IMPLIM) {
6230                             /* our own SV, created in ck_split */
6231                             SvREADONLY_off(sv);
6232                             sv_setiv(sv, PL_modcount+1);
6233                           }
6234                           else {
6235                             /* SV may belong to someone else */
6236                             SvREFCNT_dec(sv);
6237                             *svp = newSViv(PL_modcount+1);
6238                           }
6239                         }
6240                     }
6241             }
6242         }
6243         return o;
6244     }
6245     if (assign_type == ASSIGN_REF)
6246         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
6247     if (!right)
6248         right = newOP(OP_UNDEF, 0);
6249     if (right->op_type == OP_READLINE) {
6250         right->op_flags |= OPf_STACKED;
6251         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
6252                 scalar(right));
6253     }
6254     else {
6255         o = newBINOP(OP_SASSIGN, flags,
6256             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
6257     }
6258     return o;
6259 }
6260
6261 /*
6262 =for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
6263
6264 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
6265 but will be a C<dbstate> op if debugging is enabled for currently-compiled
6266 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
6267 If I<label> is non-null, it supplies the name of a label to attach to
6268 the state op; this function takes ownership of the memory pointed at by
6269 I<label>, and will free it.  I<flags> gives the eight bits of C<op_flags>
6270 for the state op.
6271
6272 If I<o> is null, the state op is returned.  Otherwise the state op is
6273 combined with I<o> into a C<lineseq> list op, which is returned.  I<o>
6274 is consumed by this function and becomes part of the returned op tree.
6275
6276 =cut
6277 */
6278
6279 OP *
6280 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
6281 {
6282     dVAR;
6283     const U32 seq = intro_my();
6284     const U32 utf8 = flags & SVf_UTF8;
6285     COP *cop;
6286
6287     flags &= ~SVf_UTF8;
6288
6289     NewOp(1101, cop, 1, COP);
6290     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
6291         cop->op_type = OP_DBSTATE;
6292         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
6293     }
6294     else {
6295         cop->op_type = OP_NEXTSTATE;
6296         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
6297     }
6298     cop->op_flags = (U8)flags;
6299     CopHINTS_set(cop, PL_hints);
6300 #ifdef NATIVE_HINTS
6301     cop->op_private |= NATIVE_HINTS;
6302 #endif
6303 #ifdef VMS
6304     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
6305 #endif
6306     cop->op_next = (OP*)cop;
6307
6308     cop->cop_seq = seq;
6309     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
6310     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
6311     if (label) {
6312         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
6313
6314         PL_hints |= HINT_BLOCK_SCOPE;
6315         /* It seems that we need to defer freeing this pointer, as other parts
6316            of the grammar end up wanting to copy it after this op has been
6317            created. */
6318         SAVEFREEPV(label);
6319     }
6320
6321     if (PL_parser->preambling != NOLINE) {
6322         CopLINE_set(cop, PL_parser->preambling);
6323         PL_parser->copline = NOLINE;
6324     }
6325     else if (PL_parser->copline == NOLINE)
6326         CopLINE_set(cop, CopLINE(PL_curcop));
6327     else {
6328         CopLINE_set(cop, PL_parser->copline);
6329         PL_parser->copline = NOLINE;
6330     }
6331 #ifdef USE_ITHREADS
6332     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
6333 #else
6334     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
6335 #endif
6336     CopSTASH_set(cop, PL_curstash);
6337
6338     if (cop->op_type == OP_DBSTATE) {
6339         /* this line can have a breakpoint - store the cop in IV */
6340         AV *av = CopFILEAVx(PL_curcop);
6341         if (av) {
6342             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
6343             if (svp && *svp != &PL_sv_undef ) {
6344                 (void)SvIOK_on(*svp);
6345                 SvIV_set(*svp, PTR2IV(cop));
6346             }
6347         }
6348     }
6349
6350     if (flags & OPf_SPECIAL)
6351         op_null((OP*)cop);
6352     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
6353 }
6354
6355 /*
6356 =for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
6357
6358 Constructs, checks, and returns a logical (flow control) op.  I<type>
6359 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
6360 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
6361 the eight bits of C<op_private>, except that the bit with value 1 is
6362 automatically set.  I<first> supplies the expression controlling the
6363 flow, and I<other> supplies the side (alternate) chain of ops; they are
6364 consumed by this function and become part of the constructed op tree.
6365
6366 =cut
6367 */
6368
6369 OP *
6370 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
6371 {
6372     PERL_ARGS_ASSERT_NEWLOGOP;
6373
6374     return new_logop(type, flags, &first, &other);
6375 }
6376
6377 STATIC OP *
6378 S_search_const(pTHX_ OP *o)
6379 {
6380     PERL_ARGS_ASSERT_SEARCH_CONST;
6381
6382     switch (o->op_type) {
6383         case OP_CONST:
6384             return o;
6385         case OP_NULL:
6386             if (o->op_flags & OPf_KIDS)
6387                 return search_const(cUNOPo->op_first);
6388             break;
6389         case OP_LEAVE:
6390         case OP_SCOPE:
6391         case OP_LINESEQ:
6392         {
6393             OP *kid;
6394             if (!(o->op_flags & OPf_KIDS))
6395                 return NULL;
6396             kid = cLISTOPo->op_first;
6397             do {
6398                 switch (kid->op_type) {
6399                     case OP_ENTER:
6400                     case OP_NULL:
6401                     case OP_NEXTSTATE:
6402                         kid = OP_SIBLING(kid);
6403                         break;
6404                     default:
6405                         if (kid != cLISTOPo->op_last)
6406                             return NULL;
6407                         goto last;
6408                 }
6409             } while (kid);
6410             if (!kid)
6411                 kid = cLISTOPo->op_last;
6412 last:
6413             return search_const(kid);
6414         }
6415     }
6416
6417     return NULL;
6418 }
6419
6420 STATIC OP *
6421 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
6422 {
6423     dVAR;
6424     LOGOP *logop;
6425     OP *o;
6426     OP *first;
6427     OP *other;
6428     OP *cstop = NULL;
6429     int prepend_not = 0;
6430
6431     PERL_ARGS_ASSERT_NEW_LOGOP;
6432
6433     first = *firstp;
6434     other = *otherp;
6435
6436     /* [perl #59802]: Warn about things like "return $a or $b", which
6437        is parsed as "(return $a) or $b" rather than "return ($a or
6438        $b)".  NB: This also applies to xor, which is why we do it
6439        here.
6440      */
6441     switch (first->op_type) {
6442     case OP_NEXT:
6443     case OP_LAST:
6444     case OP_REDO:
6445         /* XXX: Perhaps we should emit a stronger warning for these.
6446            Even with the high-precedence operator they don't seem to do
6447            anything sensible.
6448
6449            But until we do, fall through here.
6450          */
6451     case OP_RETURN:
6452     case OP_EXIT:
6453     case OP_DIE:
6454     case OP_GOTO:
6455         /* XXX: Currently we allow people to "shoot themselves in the
6456            foot" by explicitly writing "(return $a) or $b".
6457
6458            Warn unless we are looking at the result from folding or if
6459            the programmer explicitly grouped the operators like this.
6460            The former can occur with e.g.
6461
6462                 use constant FEATURE => ( $] >= ... );
6463                 sub { not FEATURE and return or do_stuff(); }
6464          */
6465         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
6466             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6467                            "Possible precedence issue with control flow operator");
6468         /* XXX: Should we optimze this to "return $a;" (i.e. remove
6469            the "or $b" part)?
6470         */
6471         break;
6472     }
6473
6474     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
6475         return newBINOP(type, flags, scalar(first), scalar(other));
6476
6477     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
6478
6479     scalarboolean(first);
6480     /* optimize AND and OR ops that have NOTs as children */
6481     if (first->op_type == OP_NOT
6482         && (first->op_flags & OPf_KIDS)
6483         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
6484             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
6485         ) {
6486         if (type == OP_AND || type == OP_OR) {
6487             if (type == OP_AND)
6488                 type = OP_OR;
6489             else
6490                 type = OP_AND;
6491             op_null(first);
6492             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
6493                 op_null(other);
6494                 prepend_not = 1; /* prepend a NOT op later */
6495             }
6496         }
6497     }
6498     /* search for a constant op that could let us fold the test */
6499     if ((cstop = search_const(first))) {
6500         if (cstop->op_private & OPpCONST_STRICT)
6501             no_bareword_allowed(cstop);
6502         else if ((cstop->op_private & OPpCONST_BARE))
6503                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
6504         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
6505             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
6506             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
6507             *firstp = NULL;
6508             if (other->op_type == OP_CONST)
6509                 other->op_private |= OPpCONST_SHORTCIRCUIT;
6510             op_free(first);
6511             if (other->op_type == OP_LEAVE)
6512                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
6513             else if (other->op_type == OP_MATCH
6514                   || other->op_type == OP_SUBST
6515                   || other->op_type == OP_TRANSR
6516                   || other->op_type == OP_TRANS)
6517                 /* Mark the op as being unbindable with =~ */
6518                 other->op_flags |= OPf_SPECIAL;
6519
6520             other->op_folded = 1;
6521             return other;
6522         }
6523         else {
6524             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
6525             const OP *o2 = other;
6526             if ( ! (o2->op_type == OP_LIST
6527                     && (( o2 = cUNOPx(o2)->op_first))
6528                     && o2->op_type == OP_PUSHMARK
6529                     && (( o2 = OP_SIBLING(o2))) )
6530             )
6531                 o2 = other;
6532             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
6533                         || o2->op_type == OP_PADHV)
6534                 && o2->op_private & OPpLVAL_INTRO
6535                 && !(o2->op_private & OPpPAD_STATE))
6536             {
6537                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6538                                  "Deprecated use of my() in false conditional");
6539             }
6540
6541             *otherp = NULL;
6542             if (cstop->op_type == OP_CONST)
6543                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
6544                 op_free(other);
6545             return first;
6546         }
6547     }
6548     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
6549         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
6550     {
6551         const OP * const k1 = ((UNOP*)first)->op_first;
6552         const OP * const k2 = OP_SIBLING(k1);
6553         OPCODE warnop = 0;
6554         switch (first->op_type)
6555         {
6556         case OP_NULL:
6557             if (k2 && k2->op_type == OP_READLINE
6558                   && (k2->op_flags & OPf_STACKED)
6559                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
6560             {
6561                 warnop = k2->op_type;
6562             }
6563             break;
6564
6565         case OP_SASSIGN:
6566             if (k1->op_type == OP_READDIR
6567                   || k1->op_type == OP_GLOB
6568                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
6569                  || k1->op_type == OP_EACH
6570                  || k1->op_type == OP_AEACH)
6571             {
6572                 warnop = ((k1->op_type == OP_NULL)
6573                           ? (OPCODE)k1->op_targ : k1->op_type);
6574             }
6575             break;
6576         }
6577         if (warnop) {
6578             const line_t oldline = CopLINE(PL_curcop);
6579             /* This ensures that warnings are reported at the first line
6580                of the construction, not the last.  */
6581             CopLINE_set(PL_curcop, PL_parser->copline);
6582             Perl_warner(aTHX_ packWARN(WARN_MISC),
6583                  "Value of %s%s can be \"0\"; test with defined()",
6584                  PL_op_desc[warnop],
6585                  ((warnop == OP_READLINE || warnop == OP_GLOB)
6586                   ? " construct" : "() operator"));
6587             CopLINE_set(PL_curcop, oldline);
6588         }
6589     }
6590
6591     if (!other)
6592         return first;
6593
6594     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
6595         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
6596
6597     logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
6598     logop->op_ppaddr = PL_ppaddr[type];
6599     logop->op_flags |= (U8)flags;
6600     logop->op_private = (U8)(1 | (flags >> 8));
6601
6602     /* establish postfix order */
6603     logop->op_next = LINKLIST(first);
6604     first->op_next = (OP*)logop;
6605     assert(!OP_HAS_SIBLING(first));
6606     op_sibling_splice((OP*)logop, first, 0, other);
6607
6608     CHECKOP(type,logop);
6609
6610     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
6611     other->op_next = o;
6612
6613     return o;
6614 }
6615
6616 /*
6617 =for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
6618
6619 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
6620 op.  I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
6621 will be set automatically, and, shifted up eight bits, the eight bits of
6622 C<op_private>, except that the bit with value 1 is automatically set.
6623 I<first> supplies the expression selecting between the two branches,
6624 and I<trueop> and I<falseop> supply the branches; they are consumed by
6625 this function and become part of the constructed op tree.
6626
6627 =cut
6628 */
6629
6630 OP *
6631 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
6632 {
6633     dVAR;
6634     LOGOP *logop;
6635     OP *start;
6636     OP *o;
6637     OP *cstop;
6638
6639     PERL_ARGS_ASSERT_NEWCONDOP;
6640
6641     if (!falseop)
6642         return newLOGOP(OP_AND, 0, first, trueop);
6643     if (!trueop)
6644         return newLOGOP(OP_OR, 0, first, falseop);
6645
6646     scalarboolean(first);
6647     if ((cstop = search_const(first))) {
6648         /* Left or right arm of the conditional?  */
6649         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
6650         OP *live = left ? trueop : falseop;
6651         OP *const dead = left ? falseop : trueop;
6652         if (cstop->op_private & OPpCONST_BARE &&
6653             cstop->op_private & OPpCONST_STRICT) {
6654             no_bareword_allowed(cstop);
6655         }
6656         op_free(first);
6657         op_free(dead);
6658         if (live->op_type == OP_LEAVE)
6659             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
6660         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
6661               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
6662             /* Mark the op as being unbindable with =~ */
6663             live->op_flags |= OPf_SPECIAL;
6664         live->op_folded = 1;
6665         return live;
6666     }
6667     logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
6668     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
6669     logop->op_flags |= (U8)flags;
6670     logop->op_private = (U8)(1 | (flags >> 8));
6671     logop->op_next = LINKLIST(falseop);
6672
6673     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
6674             logop);
6675
6676     /* establish postfix order */
6677     start = LINKLIST(first);
6678     first->op_next = (OP*)logop;
6679
6680     /* make first, trueop, falseop siblings */
6681     op_sibling_splice((OP*)logop, first,  0, trueop);
6682     op_sibling_splice((OP*)logop, trueop, 0, falseop);
6683
6684     o = newUNOP(OP_NULL, 0, (OP*)logop);
6685
6686     trueop->op_next = falseop->op_next&n