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