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