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