xref: /openbsd/gnu/usr.bin/perl/op.c (revision e0680481)
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 and manipulate the OP
23  * structures that hold a compiled perl program.
24  *
25  * Note that during the build of miniperl, a temporary copy of this file
26  * is made, called opmini.c.
27  *
28  * A Perl program is compiled into a tree of OP nodes. Each op contains:
29  *  * structural OP pointers to its children and siblings (op_sibling,
30  *    op_first etc) that define the tree structure;
31  *  * execution order OP pointers (op_next, plus sometimes op_other,
32  *    op_lastop  etc) that define the execution sequence plus variants;
33  *  * a pointer to the C "pp" function that would execute the op;
34  *  * any data specific to that op.
35  * For example, an OP_CONST op points to the pp_const() function and to an
36  * SV containing the constant value. When pp_const() is executed, its job
37  * is to push that SV onto the stack.
38  *
39  * OPs are mainly created by the newFOO() functions, which are mainly
40  * called from the parser (in perly.y) as the code is parsed. For example
41  * the Perl code $a + $b * $c would cause the equivalent of the following
42  * to be called (oversimplifying a bit):
43  *
44  *  newBINOP(OP_ADD, flags,
45  *	newSVREF($a),
46  *	newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
47  *  )
48  *
49  * As the parser reduces low-level rules, it creates little op subtrees;
50  * as higher-level rules are resolved, these subtrees get joined together
51  * as branches on a bigger subtree, until eventually a top-level rule like
52  * a subroutine definition is reduced, at which point there is one large
53  * parse tree left.
54  *
55  * The execution order pointers (op_next) are generated as the subtrees
56  * are joined together. Consider this sub-expression: A*B + C/D: at the
57  * point when it's just been parsed, the op tree looks like:
58  *
59  *   [+]
60  *    |
61  *   [*]------[/]
62  *    |        |
63  *    A---B    C---D
64  *
65  * with the intended execution order being:
66  *
67  *   [PREV] => A => B => [*] => C => D => [/] =>  [+] => [NEXT]
68  *
69  * At this point all the nodes' op_next pointers will have been set,
70  * except that:
71  *    * we don't know what the [NEXT] node will be yet;
72  *    * we don't know what the [PREV] node will be yet, but when it gets
73  *      created and needs its op_next set, it needs to be set to point to
74  *      A, which is non-obvious.
75  * To handle both those cases, we temporarily set the top node's
76  * op_next to point to the first node to be executed in this subtree (A in
77  * this case). This means that initially a subtree's op_next chain,
78  * starting from the top node, will visit each node in execution sequence
79  * then point back at the top node.
80  * When we embed this subtree in a larger tree, its top op_next is used
81  * to get the start node, then is set to point to its new neighbour.
82  * For example the two separate [*],A,B and [/],C,D subtrees would
83  * initially have had:
84  *   [*] => A;  A => B;  B => [*]
85  * and
86  *   [/] => C;  C => D;  D => [/]
87  * When these two subtrees were joined together to make the [+] subtree,
88  * [+]'s op_next was set to [*]'s op_next, i.e. A; then [*]'s op_next was
89  * set to point to [/]'s op_next, i.e. C.
90  *
91  * This op_next linking is done by the LINKLIST() macro and its underlying
92  * op_linklist() function. Given a top-level op, if its op_next is
93  * non-null, it's already been linked, so leave it. Otherwise link it with
94  * its children as described above, possibly recursively if any of the
95  * children have a null op_next.
96  *
97  * In summary: given a subtree, its top-level node's op_next will either
98  * be:
99  *   NULL: the subtree hasn't been LINKLIST()ed yet;
100  *   fake: points to the start op for this subtree;
101  *   real: once the subtree has been embedded into a larger tree
102  */
103 
104 /*
105 
106 Here's an older description from Larry.
107 
108 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
109 
110     A bottom-up pass
111     A top-down pass
112     An execution-order pass
113 
114 The bottom-up pass is represented by all the "newOP" routines and
115 the ck_ routines.  The bottom-upness is actually driven by yacc.
116 So at the point that a ck_ routine fires, we have no idea what the
117 context is, either upward in the syntax tree, or either forward or
118 backward in the execution order.  (The bottom-up parser builds that
119 part of the execution order it knows about, but if you follow the "next"
120 links around, you'll find it's actually a closed loop through the
121 top level node.)
122 
123 Whenever the bottom-up parser gets to a node that supplies context to
124 its components, it invokes that portion of the top-down pass that applies
125 to that part of the subtree (and marks the top node as processed, so
126 if a node further up supplies context, it doesn't have to take the
127 plunge again).  As a particular subcase of this, as the new node is
128 built, it takes all the closed execution loops of its subcomponents
129 and links them into a new closed loop for the higher level node.  But
130 it's still not the real execution order.
131 
132 The actual execution order is not known till we get a grammar reduction
133 to a top-level unit like a subroutine or file that will be called by
134 "name" rather than via a "next" pointer.  At that point, we can call
135 into peep() to do that code's portion of the 3rd pass.  It has to be
136 recursive, but it's recursive on basic blocks, not on tree nodes.
137 */
138 
139 /* To implement user lexical pragmas, there needs to be a way at run time to
140    get the compile time state of %^H for that block.  Storing %^H in every
141    block (or even COP) would be very expensive, so a different approach is
142    taken.  The (running) state of %^H is serialised into a tree of HE-like
143    structs.  Stores into %^H are chained onto the current leaf as a struct
144    refcounted_he * with the key and the value.  Deletes from %^H are saved
145    with a value of PL_sv_placeholder.  The state of %^H at any point can be
146    turned back into a regular HV by walking back up the tree from that point's
147    leaf, ignoring any key you've already seen (placeholder or not), storing
148    the rest into the HV structure, then removing the placeholders. Hence
149    memory is only used to store the %^H deltas from the enclosing COP, rather
150    than the entire %^H on each COP.
151 
152    To cause actions on %^H to write out the serialisation records, it has
153    magic type 'H'. This magic (itself) does nothing, but its presence causes
154    the values to gain magic type 'h', which has entries for set and clear.
155    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
156    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
157    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
158    it will be correctly restored when any inner compiling scope is exited.
159 */
160 
161 #include "EXTERN.h"
162 #define PERL_IN_OP_C
163 #include "perl.h"
164 #include "keywords.h"
165 #include "feature.h"
166 #include "regcomp.h"
167 #include "invlist_inline.h"
168 
169 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
170 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
171 
172 static const char array_passed_to_stat[] = "Array passed to stat will be coerced to a scalar";
173 
174 /* remove any leading "empty" ops from the op_next chain whose first
175  * node's address is stored in op_p. Store the updated address of the
176  * first node in op_p.
177  */
178 
179 void
Perl_op_prune_chain_head(OP ** op_p)180 Perl_op_prune_chain_head(OP** op_p)
181 {
182     PERL_ARGS_ASSERT_OP_PRUNE_CHAIN_HEAD;
183 
184     while (*op_p
185         && (   (*op_p)->op_type == OP_NULL
186             || (*op_p)->op_type == OP_SCOPE
187             || (*op_p)->op_type == OP_SCALAR
188             || (*op_p)->op_type == OP_LINESEQ)
189     )
190         *op_p = (*op_p)->op_next;
191 }
192 
193 
194 /* See the explanatory comments above struct opslab in op.h. */
195 
196 #ifdef PERL_DEBUG_READONLY_OPS
197 #  define PERL_SLAB_SIZE 128
198 #  define PERL_MAX_SLAB_SIZE 4096
199 #  include <sys/mman.h>
200 #endif
201 
202 #ifndef PERL_SLAB_SIZE
203 #  define PERL_SLAB_SIZE 64
204 #endif
205 #ifndef PERL_MAX_SLAB_SIZE
206 #  define PERL_MAX_SLAB_SIZE 2048
207 #endif
208 
209 /* rounds up to nearest pointer */
210 #define SIZE_TO_PSIZE(x)	(((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
211 
212 #define DIFF(o,p)	\
213     (assert(((char *)(p) - (char *)(o)) % sizeof(I32**) == 0), \
214       ((size_t)((I32 **)(p) - (I32**)(o))))
215 
216 /* requires double parens and aTHX_ */
217 #define DEBUG_S_warn(args)					       \
218     DEBUG_S( 								\
219         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
220     )
221 
222 /* opslot_size includes the size of the slot header, and an op can't be smaller than BASEOP */
223 #define OPSLOT_SIZE_BASE (SIZE_TO_PSIZE(sizeof(OPSLOT)))
224 
225 /* the number of bytes to allocate for a slab with sz * sizeof(I32 **) space for op */
226 #define OpSLABSizeBytes(sz) \
227     ((sz) * sizeof(I32 *) + STRUCT_OFFSET(OPSLAB, opslab_slots))
228 
229 /* malloc a new op slab (suitable for attaching to PL_compcv).
230  * sz is in units of pointers from the beginning of opslab_opslots */
231 
232 static OPSLAB *
S_new_slab(pTHX_ OPSLAB * head,size_t sz)233 S_new_slab(pTHX_ OPSLAB *head, size_t sz)
234 {
235     OPSLAB *slab;
236     size_t sz_bytes = OpSLABSizeBytes(sz);
237 
238     /* opslot_offset is only U16 */
239     assert(sz < U16_MAX);
240     /* room for at least one op */
241     assert(sz >= OPSLOT_SIZE_BASE);
242 
243 #ifdef PERL_DEBUG_READONLY_OPS
244     slab = (OPSLAB *) mmap(0, sz_bytes,
245                                    PROT_READ|PROT_WRITE,
246                                    MAP_ANON|MAP_PRIVATE, -1, 0);
247     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
248                           (unsigned long) sz, slab));
249     if (slab == MAP_FAILED) {
250         perror("mmap failed");
251         abort();
252     }
253 #else
254     slab = (OPSLAB *)PerlMemShared_malloc(sz_bytes);
255     Zero(slab, sz_bytes, char);
256 #endif
257     slab->opslab_size = (U16)sz;
258 
259 #ifndef WIN32
260     /* The context is unused in non-Windows */
261     PERL_UNUSED_CONTEXT;
262 #endif
263     slab->opslab_free_space = sz;
264     slab->opslab_head = head ? head : slab;
265     DEBUG_S_warn((aTHX_ "allocated new op slab sz 0x%x, %p, head slab %p",
266         (unsigned int)slab->opslab_size, (void*)slab,
267         (void*)(slab->opslab_head)));
268     return slab;
269 }
270 
271 #define OPSLOT_SIZE_TO_INDEX(sz) ((sz) - OPSLOT_SIZE_BASE)
272 
273 #define link_freed_op(slab, o) S_link_freed_op(aTHX_ slab, o)
274 static void
S_link_freed_op(pTHX_ OPSLAB * slab,OP * o)275 S_link_freed_op(pTHX_ OPSLAB *slab, OP *o) {
276     U16 sz = OpSLOT(o)->opslot_size;
277     U16 index = OPSLOT_SIZE_TO_INDEX(sz);
278 
279     assert(sz >= OPSLOT_SIZE_BASE);
280     /* make sure the array is large enough to include ops this large */
281     if (!slab->opslab_freed) {
282         /* we don't have a free list array yet, make a new one */
283         slab->opslab_freed_size = index+1;
284         slab->opslab_freed = (OP**)PerlMemShared_calloc((slab->opslab_freed_size), sizeof(OP*));
285 
286         if (!slab->opslab_freed)
287             croak_no_mem();
288     }
289     else if (index >= slab->opslab_freed_size) {
290         /* It's probably not worth doing exponential expansion here, the number of op sizes
291            is small.
292         */
293         /* We already have a list that isn't large enough, expand it */
294         size_t newsize = index+1;
295         OP **p = (OP **)PerlMemShared_realloc(slab->opslab_freed, newsize * sizeof(OP*));
296 
297         if (!p)
298             croak_no_mem();
299 
300         Zero(p+slab->opslab_freed_size, newsize - slab->opslab_freed_size, OP *);
301 
302         slab->opslab_freed = p;
303         slab->opslab_freed_size = newsize;
304     }
305 
306     o->op_next = slab->opslab_freed[index];
307     slab->opslab_freed[index] = o;
308 }
309 
310 /* Returns a sz-sized block of memory (suitable for holding an op) from
311  * a free slot in the chain of op slabs attached to PL_compcv.
312  * Allocates a new slab if necessary.
313  * if PL_compcv isn't compiling, malloc() instead.
314  */
315 
316 void *
Perl_Slab_Alloc(pTHX_ size_t sz)317 Perl_Slab_Alloc(pTHX_ size_t sz)
318 {
319     OPSLAB *head_slab; /* first slab in the chain */
320     OPSLAB *slab2;
321     OPSLOT *slot;
322     OP *o;
323     size_t sz_in_p; /* size in pointer units, including the OPSLOT header */
324 
325     /* We only allocate ops from the slab during subroutine compilation.
326        We find the slab via PL_compcv, hence that must be non-NULL. It could
327        also be pointing to a subroutine which is now fully set up (CvROOT()
328        pointing to the top of the optree for that sub), or a subroutine
329        which isn't using the slab allocator. If our sanity checks aren't met,
330        don't use a slab, but allocate the OP directly from the heap.  */
331     if (!PL_compcv || CvROOT(PL_compcv)
332      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
333     {
334         o = (OP*)PerlMemShared_calloc(1, sz);
335         goto gotit;
336     }
337 
338     /* While the subroutine is under construction, the slabs are accessed via
339        CvSTART(), to avoid needing to expand PVCV by one pointer for something
340        unneeded at runtime. Once a subroutine is constructed, the slabs are
341        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
342        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
343        details.  */
344     if (!CvSTART(PL_compcv)) {
345         CvSTART(PL_compcv) =
346             (OP *)(head_slab = S_new_slab(aTHX_ NULL, PERL_SLAB_SIZE));
347         CvSLABBED_on(PL_compcv);
348         head_slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
349     }
350     else ++(head_slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
351 
352     sz_in_p = SIZE_TO_PSIZE(sz + OPSLOT_HEADER);
353 
354     /* The head slab for each CV maintains a free list of OPs. In particular, constant folding
355        will free up OPs, so it makes sense to re-use them where possible. A
356        freed up slot is used in preference to a new allocation.  */
357     if (head_slab->opslab_freed &&
358         OPSLOT_SIZE_TO_INDEX(sz_in_p) < head_slab->opslab_freed_size) {
359         U16 base_index;
360 
361         /* look for a large enough size with any freed ops */
362         for (base_index = OPSLOT_SIZE_TO_INDEX(sz_in_p);
363              base_index < head_slab->opslab_freed_size && !head_slab->opslab_freed[base_index];
364              ++base_index) {
365         }
366 
367         if (base_index < head_slab->opslab_freed_size) {
368             /* found a freed op */
369             o = head_slab->opslab_freed[base_index];
370 
371             DEBUG_S_warn((aTHX_ "realloced  op at %p, slab %p, head slab %p",
372                           (void *)o, (void *)OpMySLAB(o), (void *)head_slab));
373             head_slab->opslab_freed[base_index] = o->op_next;
374             Zero(o, sz, char);
375             o->op_slabbed = 1;
376             goto gotit;
377         }
378     }
379 
380 #define INIT_OPSLOT(s) \
381             slot->opslot_offset = DIFF(&slab2->opslab_slots, slot) ;	\
382             slot->opslot_size = s;                      \
383             slab2->opslab_free_space -= s;		\
384             o = &slot->opslot_op;			\
385             o->op_slabbed = 1
386 
387     /* The partially-filled slab is next in the chain. */
388     slab2 = head_slab->opslab_next ? head_slab->opslab_next : head_slab;
389     if (slab2->opslab_free_space < sz_in_p) {
390         /* Remaining space is too small. */
391         /* If we can fit a BASEOP, add it to the free chain, so as not
392            to waste it. */
393         if (slab2->opslab_free_space >= OPSLOT_SIZE_BASE) {
394             slot = &slab2->opslab_slots;
395             INIT_OPSLOT(slab2->opslab_free_space);
396             o->op_type = OP_FREED;
397             DEBUG_S_warn((aTHX_ "linked unused op space at %p, slab %p, head slab %p",
398                           (void *)o, (void *)slab2, (void *)head_slab));
399             link_freed_op(head_slab, o);
400         }
401 
402         /* Create a new slab.  Make this one twice as big. */
403         slab2 = S_new_slab(aTHX_ head_slab,
404                             slab2->opslab_size  > PERL_MAX_SLAB_SIZE / 2
405                                 ? PERL_MAX_SLAB_SIZE
406                                 : slab2->opslab_size * 2);
407         slab2->opslab_next = head_slab->opslab_next;
408         head_slab->opslab_next = slab2;
409     }
410     assert(slab2->opslab_size >= sz_in_p);
411 
412     /* Create a new op slot */
413     slot = OpSLOToff(slab2, slab2->opslab_free_space - sz_in_p);
414     assert(slot >= &slab2->opslab_slots);
415     INIT_OPSLOT(sz_in_p);
416     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p, head slab %p",
417         (void*)o, (void*)slab2, (void*)head_slab));
418 
419   gotit:
420     /* moresib == 0, op_sibling == 0 implies a solitary unattached op */
421     assert(!o->op_moresib);
422     assert(!o->op_sibparent);
423 
424     return (void *)o;
425 }
426 
427 #undef INIT_OPSLOT
428 
429 #ifdef PERL_DEBUG_READONLY_OPS
430 void
Perl_Slab_to_ro(pTHX_ OPSLAB * slab)431 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
432 {
433     PERL_ARGS_ASSERT_SLAB_TO_RO;
434 
435     if (slab->opslab_readonly) return;
436     slab->opslab_readonly = 1;
437     for (; slab; slab = slab->opslab_next) {
438         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
439                               (unsigned long) slab->opslab_size, (void *)slab));*/
440         if (mprotect(slab, OpSLABSizeBytes(slab->opslab_size), PROT_READ))
441             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", (void *)slab,
442                              (unsigned long)slab->opslab_size, errno);
443     }
444 }
445 
446 void
Perl_Slab_to_rw(pTHX_ OPSLAB * const slab)447 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
448 {
449     OPSLAB *slab2;
450 
451     PERL_ARGS_ASSERT_SLAB_TO_RW;
452 
453     if (!slab->opslab_readonly) return;
454     slab2 = slab;
455     for (; slab2; slab2 = slab2->opslab_next) {
456         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
457                               (unsigned long) size, (void *)slab2));*/
458         if (mprotect((void *)slab2, OpSLABSizeBytes(slab2->opslab_size),
459                      PROT_READ|PROT_WRITE)) {
460             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", (void *)slab,
461                              (unsigned long)slab2->opslab_size, errno);
462         }
463     }
464     slab->opslab_readonly = 0;
465 }
466 
467 #else
468 #  define Slab_to_rw(op)    NOOP
469 #endif
470 
471 /* make freed ops die if they're inadvertently executed */
472 #ifdef DEBUGGING
473 static OP *
S_pp_freed(pTHX)474 S_pp_freed(pTHX)
475 {
476     DIE(aTHX_ "panic: freed op 0x%p called\n", PL_op);
477 }
478 #endif
479 
480 
481 /* Return the block of memory used by an op to the free list of
482  * the OP slab associated with that op.
483  */
484 
485 void
Perl_Slab_Free(pTHX_ void * op)486 Perl_Slab_Free(pTHX_ void *op)
487 {
488     OP * const o = (OP *)op;
489     OPSLAB *slab;
490 
491     PERL_ARGS_ASSERT_SLAB_FREE;
492 
493 #ifdef DEBUGGING
494     o->op_ppaddr = S_pp_freed;
495 #endif
496 
497     if (!o->op_slabbed) {
498         if (!o->op_static)
499             PerlMemShared_free(op);
500         return;
501     }
502 
503     slab = OpSLAB(o);
504     /* If this op is already freed, our refcount will get screwy. */
505     assert(o->op_type != OP_FREED);
506     o->op_type = OP_FREED;
507     link_freed_op(slab, o);
508     DEBUG_S_warn((aTHX_ "freeing    op at %p, slab %p, head slab %p",
509         (void*)o, (void *)OpMySLAB(o), (void*)slab));
510     OpslabREFCNT_dec_padok(slab);
511 }
512 
513 void
Perl_opslab_free_nopad(pTHX_ OPSLAB * slab)514 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
515 {
516     const bool havepad = cBOOL(PL_comppad);
517     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
518     if (havepad) {
519         ENTER;
520         PAD_SAVE_SETNULLPAD();
521     }
522     opslab_free(slab);
523     if (havepad) LEAVE;
524 }
525 
526 /* Free a chain of OP slabs. Should only be called after all ops contained
527  * in it have been freed. At this point, its reference count should be 1,
528  * because OpslabREFCNT_dec() skips doing rc-- when it detects that rc == 1,
529  * and just directly calls opslab_free().
530  * (Note that the reference count which PL_compcv held on the slab should
531  * have been removed once compilation of the sub was complete).
532  *
533  *
534  */
535 
536 void
Perl_opslab_free(pTHX_ OPSLAB * slab)537 Perl_opslab_free(pTHX_ OPSLAB *slab)
538 {
539     OPSLAB *slab2;
540     PERL_ARGS_ASSERT_OPSLAB_FREE;
541     PERL_UNUSED_CONTEXT;
542     DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab));
543     assert(slab->opslab_refcnt == 1);
544     PerlMemShared_free(slab->opslab_freed);
545     do {
546         slab2 = slab->opslab_next;
547 #ifdef DEBUGGING
548         slab->opslab_refcnt = ~(size_t)0;
549 #endif
550 #ifdef PERL_DEBUG_READONLY_OPS
551         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
552                                                (void*)slab));
553         if (munmap(slab, OpSLABSizeBytes(slab->opslab_size))) {
554             perror("munmap failed");
555             abort();
556         }
557 #else
558         PerlMemShared_free(slab);
559 #endif
560         slab = slab2;
561     } while (slab);
562 }
563 
564 /* like opslab_free(), but first calls op_free() on any ops in the slab
565  * not marked as OP_FREED
566  */
567 
568 void
Perl_opslab_force_free(pTHX_ OPSLAB * slab)569 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
570 {
571     OPSLAB *slab2;
572 #ifdef DEBUGGING
573     size_t savestack_count = 0;
574 #endif
575     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
576     slab2 = slab;
577     do {
578         OPSLOT *slot = OpSLOToff(slab2, slab2->opslab_free_space);
579         OPSLOT *end  = OpSLOToff(slab2, slab2->opslab_size);
580         for (; slot < end;
581                 slot = (OPSLOT*) ((I32**)slot + slot->opslot_size) )
582         {
583             if (slot->opslot_op.op_type != OP_FREED
584              && !(slot->opslot_op.op_savefree
585 #ifdef DEBUGGING
586                   && ++savestack_count
587 #endif
588                  )
589             ) {
590                 assert(slot->opslot_op.op_slabbed);
591                 op_free(&slot->opslot_op);
592                 if (slab->opslab_refcnt == 1) goto free;
593             }
594         }
595     } while ((slab2 = slab2->opslab_next));
596     /* > 1 because the CV still holds a reference count. */
597     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
598 #ifdef DEBUGGING
599         assert(savestack_count == slab->opslab_refcnt-1);
600 #endif
601         /* Remove the CV’s reference count. */
602         slab->opslab_refcnt--;
603         return;
604     }
605    free:
606     opslab_free(slab);
607 }
608 
609 #ifdef PERL_DEBUG_READONLY_OPS
610 OP *
Perl_op_refcnt_inc(pTHX_ OP * o)611 Perl_op_refcnt_inc(pTHX_ OP *o)
612 {
613     if(o) {
614         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
615         if (slab && slab->opslab_readonly) {
616             Slab_to_rw(slab);
617             ++o->op_targ;
618             Slab_to_ro(slab);
619         } else {
620             ++o->op_targ;
621         }
622     }
623     return o;
624 
625 }
626 
627 PADOFFSET
Perl_op_refcnt_dec(pTHX_ OP * o)628 Perl_op_refcnt_dec(pTHX_ OP *o)
629 {
630     PADOFFSET result;
631     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
632 
633     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
634 
635     if (slab && slab->opslab_readonly) {
636         Slab_to_rw(slab);
637         result = --o->op_targ;
638         Slab_to_ro(slab);
639     } else {
640         result = --o->op_targ;
641     }
642     return result;
643 }
644 #endif
645 /*
646  * In the following definition, the ", (OP*)0" is just to make the compiler
647  * think the expression is of the right type: croak actually does a Siglongjmp.
648  */
649 #define CHECKOP(type,o) \
650     ((PL_op_mask && PL_op_mask[type])				\
651      ? ( op_free((OP*)o),					\
652          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),	\
653          (OP*)0 )						\
654      : PL_check[type](aTHX_ (OP*)o))
655 
656 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
657 
658 STATIC OP *
S_no_fh_allowed(pTHX_ OP * o)659 S_no_fh_allowed(pTHX_ OP *o)
660 {
661     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
662 
663     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
664                  OP_DESC(o)));
665     return o;
666 }
667 
668 STATIC OP *
S_too_few_arguments_pv(pTHX_ OP * o,const char * name,U32 flags)669 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
670 {
671     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
672     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
673     return o;
674 }
675 
676 STATIC OP *
S_too_many_arguments_pv(pTHX_ OP * o,const char * name,U32 flags)677 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
678 {
679     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
680 
681     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
682     return o;
683 }
684 
685 STATIC void
S_bad_type_pv(pTHX_ I32 n,const char * t,const OP * o,const OP * kid)686 S_bad_type_pv(pTHX_ I32 n, const char *t, const OP *o, const OP *kid)
687 {
688     PERL_ARGS_ASSERT_BAD_TYPE_PV;
689 
690     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
691                  (int)n, PL_op_desc[(o)->op_type], t, OP_DESC(kid)), 0);
692 }
693 
694 STATIC void
S_bad_type_gv(pTHX_ I32 n,GV * gv,const OP * kid,const char * t)695 S_bad_type_gv(pTHX_ I32 n, GV *gv, const OP *kid, const char *t)
696 {
697     SV * const namesv = cv_name((CV *)gv, NULL, 0);
698     PERL_ARGS_ASSERT_BAD_TYPE_GV;
699 
700     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %" SVf " must be %s (not %s)",
701                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv));
702 }
703 
704 void
Perl_no_bareword_allowed(pTHX_ OP * o)705 Perl_no_bareword_allowed(pTHX_ OP *o)
706 {
707     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
708 
709     qerror(Perl_mess(aTHX_
710                      "Bareword \"%" SVf "\" not allowed while \"strict subs\" in use",
711                      SVfARG(cSVOPo_sv)));
712     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
713 }
714 
715 void
Perl_no_bareword_filehandle(pTHX_ const char * fhname)716 Perl_no_bareword_filehandle(pTHX_ const char *fhname) {
717     PERL_ARGS_ASSERT_NO_BAREWORD_FILEHANDLE;
718 
719     if (strNE(fhname, "STDERR")
720         && strNE(fhname, "STDOUT")
721         && strNE(fhname, "STDIN")
722         && strNE(fhname, "_")
723         && strNE(fhname, "ARGV")
724         && strNE(fhname, "ARGVOUT")
725         && strNE(fhname, "DATA")) {
726         qerror(Perl_mess(aTHX_ "Bareword filehandle \"%s\" not allowed under 'no feature \"bareword_filehandles\"'", fhname));
727     }
728 }
729 
730 /* "register" allocation */
731 
732 PADOFFSET
Perl_allocmy(pTHX_ const char * const name,const STRLEN len,const U32 flags)733 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
734 {
735     PADOFFSET off;
736     bool is_idfirst, is_default;
737     const bool is_our = (PL_parser->in_my == KEY_our);
738 
739     PERL_ARGS_ASSERT_ALLOCMY;
740 
741     if (flags & ~SVf_UTF8)
742         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
743                    (UV)flags);
744 
745     is_idfirst = flags & SVf_UTF8
746         ? isIDFIRST_utf8_safe((U8*)name + 1, name + len)
747         : isIDFIRST_A(name[1]);
748 
749     /* $_, @_, etc. */
750     is_default = len == 2 && name[1] == '_';
751 
752     /* complain about "my $<special_var>" etc etc */
753     if (!is_our && (!is_idfirst || is_default)) {
754         const char * const type =
755               PL_parser->in_my == KEY_sigvar ? "subroutine signature" :
756               PL_parser->in_my == KEY_state  ? "\"state\""     : "\"my\"";
757 
758         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
759          && isASCII(name[1])
760          && (!isPRINT(name[1]) || memCHRs("\t\n\r\f", name[1]))) {
761             /* diag_listed_as: Can't use global %s in %s */
762             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in %s",
763                               name[0], toCTRL(name[1]),
764                               (int)(len - 2), name + 2,
765                               type));
766         } else {
767             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in %s",
768                               (int) len, name,
769                               type), flags & SVf_UTF8);
770         }
771     }
772 
773     /* allocate a spare slot and store the name in that slot */
774 
775     U32 addflags = 0;
776     if(is_our)
777         addflags |= padadd_OUR;
778     else if(PL_parser->in_my == KEY_state)
779         addflags |= padadd_STATE;
780     else if(PL_parser->in_my == KEY_field)
781         addflags |= padadd_FIELD;
782 
783     off = pad_add_name_pvn(name, len, addflags,
784                     PL_parser->in_my_stash,
785                     (is_our
786                         /* $_ is always in main::, even with our */
787                         ? (PL_curstash && !memEQs(name,len,"$_")
788                             ? PL_curstash
789                             : PL_defstash)
790                         : NULL
791                     )
792     );
793     /* anon sub prototypes contains state vars should always be cloned,
794      * otherwise the state var would be shared between anon subs */
795 
796     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
797         CvCLONE_on(PL_compcv);
798 
799     return off;
800 }
801 
802 /*
803 =for apidoc_section $optree_manipulation
804 
805 =for apidoc alloccopstash
806 
807 Available only under threaded builds, this function allocates an entry in
808 C<PL_stashpad> for the stash passed to it.
809 
810 =cut
811 */
812 
813 #ifdef USE_ITHREADS
814 PADOFFSET
Perl_alloccopstash(pTHX_ HV * hv)815 Perl_alloccopstash(pTHX_ HV *hv)
816 {
817     PADOFFSET off = 0, o = 1;
818     bool found_slot = FALSE;
819 
820     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
821 
822     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
823 
824     for (; o < PL_stashpadmax; ++o) {
825         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
826         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
827             found_slot = TRUE, off = o;
828     }
829     if (!found_slot) {
830         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
831         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
832         off = PL_stashpadmax;
833         PL_stashpadmax += 10;
834     }
835 
836     PL_stashpad[PL_stashpadix = off] = hv;
837     return off;
838 }
839 #endif
840 
841 /* free the body of an op without examining its contents.
842  * Always use this rather than FreeOp directly */
843 
844 static void
S_op_destroy(pTHX_ OP * o)845 S_op_destroy(pTHX_ OP *o)
846 {
847     FreeOp(o);
848 }
849 
850 /* Destructor */
851 
852 /*
853 =for apidoc op_free
854 
855 Free an op and its children. Only use this when an op is no longer linked
856 to from any optree.
857 
858 Remember that any op with C<OPf_KIDS> set is expected to have a valid
859 C<op_first> pointer.  If you are attempting to free an op but preserve its
860 child op, make sure to clear that flag before calling C<op_free()>.  For
861 example:
862 
863     OP *kid = o->op_first; o->op_first = NULL;
864     o->op_flags &= ~OPf_KIDS;
865     op_free(o);
866 
867 =cut
868 */
869 
870 void
Perl_op_free(pTHX_ OP * o)871 Perl_op_free(pTHX_ OP *o)
872 {
873     OPCODE type;
874     OP *top_op = o;
875     OP *next_op = o;
876     bool went_up = FALSE; /* whether we reached the current node by
877                             following the parent pointer from a child, and
878                             so have already seen this node */
879 
880     if (!o || o->op_type == OP_FREED)
881         return;
882 
883     if (o->op_private & OPpREFCOUNTED) {
884         /* if base of tree is refcounted, just decrement */
885         switch (o->op_type) {
886         case OP_LEAVESUB:
887         case OP_LEAVESUBLV:
888         case OP_LEAVEEVAL:
889         case OP_LEAVE:
890         case OP_SCOPE:
891         case OP_LEAVEWRITE:
892             {
893                 PADOFFSET refcnt;
894                 OP_REFCNT_LOCK;
895                 refcnt = OpREFCNT_dec(o);
896                 OP_REFCNT_UNLOCK;
897                 if (refcnt) {
898                     /* Need to find and remove any pattern match ops from
899                      * the list we maintain for reset().  */
900                     find_and_forget_pmops(o);
901                     return;
902                 }
903             }
904             break;
905         default:
906             break;
907         }
908     }
909 
910     while (next_op) {
911         o = next_op;
912 
913         /* free child ops before ourself, (then free ourself "on the
914          * way back up") */
915 
916         /* Ensure the caller maintains the relationship between OPf_KIDS and
917          * op_first != NULL when restructuring the tree
918          *   https://github.com/Perl/perl5/issues/20764
919          */
920         assert(!(o->op_flags & OPf_KIDS) || cUNOPo->op_first);
921 
922         if (!went_up && o->op_flags & OPf_KIDS) {
923             next_op = cUNOPo->op_first;
924             continue;
925         }
926 
927         /* find the next node to visit, *then* free the current node
928          * (can't rely on o->op_* fields being valid after o has been
929          * freed) */
930 
931         /* The next node to visit will be either the sibling, or the
932          * parent if no siblings left, or NULL if we've worked our way
933          * back up to the top node in the tree */
934         next_op = (o == top_op) ? NULL : o->op_sibparent;
935         went_up = cBOOL(!OpHAS_SIBLING(o)); /* parents are already visited */
936 
937         /* Now process the current node */
938 
939         /* Though ops may be freed twice, freeing the op after its slab is a
940            big no-no. */
941         assert(!o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
942         /* During the forced freeing of ops after compilation failure, kidops
943            may be freed before their parents. */
944         if (!o || o->op_type == OP_FREED)
945             continue;
946 
947         type = o->op_type;
948 
949         /* an op should only ever acquire op_private flags that we know about.
950          * If this fails, you may need to fix something in regen/op_private.
951          * Don't bother testing if:
952          *   * the op_ppaddr doesn't match the op; someone may have
953          *     overridden the op and be doing strange things with it;
954          *   * we've errored, as op flags are often left in an
955          *     inconsistent state then. Note that an error when
956          *     compiling the main program leaves PL_parser NULL, so
957          *     we can't spot faults in the main code, only
958          *     evaled/required code;
959          *   * it's a banned op - we may be croaking before the op is
960          *     fully formed. - see CHECKOP. */
961 #ifdef DEBUGGING
962         if (   o->op_ppaddr == PL_ppaddr[type]
963             && PL_parser
964             && !PL_parser->error_count
965             && !(PL_op_mask && PL_op_mask[type])
966         )
967         {
968             assert(!(o->op_private & ~PL_op_private_valid[type]));
969         }
970 #endif
971 
972 
973         /* Call the op_free hook if it has been set. Do it now so that it's called
974          * at the right time for refcounted ops, but still before all of the kids
975          * are freed. */
976         CALL_OPFREEHOOK(o);
977 
978         if (type == OP_NULL)
979             type = (OPCODE)o->op_targ;
980 
981         if (o->op_slabbed)
982             Slab_to_rw(OpSLAB(o));
983 
984         /* COP* is not cleared by op_clear() so that we may track line
985          * numbers etc even after null() */
986         if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
987             cop_free((COP*)o);
988         }
989 
990         op_clear(o);
991         FreeOp(o);
992         if (PL_op == o)
993             PL_op = NULL;
994     }
995 }
996 
997 
998 /* S_op_clear_gv(): free a GV attached to an OP */
999 
1000 STATIC
1001 #ifdef USE_ITHREADS
S_op_clear_gv(pTHX_ OP * o,PADOFFSET * ixp)1002 void S_op_clear_gv(pTHX_ OP *o, PADOFFSET *ixp)
1003 #else
1004 void S_op_clear_gv(pTHX_ OP *o, SV**svp)
1005 #endif
1006 {
1007 
1008     GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV
1009             || o->op_type == OP_MULTIDEREF)
1010 #ifdef USE_ITHREADS
1011                 && PL_curpad
1012                 ? ((GV*)PAD_SVl(*ixp)) : NULL;
1013 #else
1014                 ? (GV*)(*svp) : NULL;
1015 #endif
1016     /* It's possible during global destruction that the GV is freed
1017        before the optree. Whilst the SvREFCNT_inc is happy to bump from
1018        0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
1019        will trigger an assertion failure, because the entry to sv_clear
1020        checks that the scalar is not already freed.  A check of for
1021        !SvIS_FREED(gv) turns out to be invalid, because during global
1022        destruction the reference count can be forced down to zero
1023        (with SVf_BREAK set).  In which case raising to 1 and then
1024        dropping to 0 triggers cleanup before it should happen.  I
1025        *think* that this might actually be a general, systematic,
1026        weakness of the whole idea of SVf_BREAK, in that code *is*
1027        allowed to raise and lower references during global destruction,
1028        so any *valid* code that happens to do this during global
1029        destruction might well trigger premature cleanup.  */
1030     bool still_valid = gv && SvREFCNT(gv);
1031 
1032     if (still_valid)
1033         SvREFCNT_inc_simple_void(gv);
1034 #ifdef USE_ITHREADS
1035     if (*ixp > 0) {
1036         pad_swipe(*ixp, TRUE);
1037         *ixp = 0;
1038     }
1039 #else
1040     SvREFCNT_dec(*svp);
1041     *svp = NULL;
1042 #endif
1043     if (still_valid) {
1044         int try_downgrade = SvREFCNT(gv) == 2;
1045         SvREFCNT_dec_NN(gv);
1046         if (try_downgrade)
1047             gv_try_downgrade(gv);
1048     }
1049 }
1050 
1051 
1052 void
Perl_op_clear(pTHX_ OP * o)1053 Perl_op_clear(pTHX_ OP *o)
1054 {
1055 
1056 
1057     PERL_ARGS_ASSERT_OP_CLEAR;
1058 
1059     switch (o->op_type) {
1060     case OP_NULL:	/* Was holding old type, if any. */
1061         /* FALLTHROUGH */
1062     case OP_ENTERTRY:
1063     case OP_ENTEREVAL:	/* Was holding hints. */
1064     case OP_ARGDEFELEM:	/* Was holding signature index. */
1065         o->op_targ = 0;
1066         break;
1067     default:
1068         if (!(o->op_flags & OPf_REF) || !OP_IS_STAT(o->op_type))
1069             break;
1070         /* FALLTHROUGH */
1071     case OP_GVSV:
1072     case OP_GV:
1073     case OP_AELEMFAST:
1074 #ifdef USE_ITHREADS
1075             S_op_clear_gv(aTHX_ o, &(cPADOPx(o)->op_padix));
1076 #else
1077             S_op_clear_gv(aTHX_ o, &(cSVOPx(o)->op_sv));
1078 #endif
1079         break;
1080     case OP_METHOD_REDIR:
1081     case OP_METHOD_REDIR_SUPER:
1082 #ifdef USE_ITHREADS
1083         if (cMETHOPo->op_rclass_targ) {
1084             pad_swipe(cMETHOPo->op_rclass_targ, 1);
1085             cMETHOPo->op_rclass_targ = 0;
1086         }
1087 #else
1088         SvREFCNT_dec(cMETHOPo->op_rclass_sv);
1089         cMETHOPo->op_rclass_sv = NULL;
1090 #endif
1091         /* FALLTHROUGH */
1092     case OP_METHOD_NAMED:
1093     case OP_METHOD_SUPER:
1094         SvREFCNT_dec(cMETHOPo->op_u.op_meth_sv);
1095         cMETHOPo->op_u.op_meth_sv = NULL;
1096 #ifdef USE_ITHREADS
1097         if (o->op_targ) {
1098             pad_swipe(o->op_targ, 1);
1099             o->op_targ = 0;
1100         }
1101 #endif
1102         break;
1103     case OP_CONST:
1104     case OP_HINTSEVAL:
1105         SvREFCNT_dec(cSVOPo->op_sv);
1106         cSVOPo->op_sv = NULL;
1107 #ifdef USE_ITHREADS
1108         /** Bug #15654
1109           Even if op_clear does a pad_free for the target of the op,
1110           pad_free doesn't actually remove the sv that exists in the pad;
1111           instead it lives on. This results in that it could be reused as
1112           a target later on when the pad was reallocated.
1113         **/
1114         if(o->op_targ) {
1115           pad_swipe(o->op_targ,1);
1116           o->op_targ = 0;
1117         }
1118 #endif
1119         break;
1120     case OP_DUMP:
1121     case OP_GOTO:
1122     case OP_NEXT:
1123     case OP_LAST:
1124     case OP_REDO:
1125         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1126             break;
1127         /* FALLTHROUGH */
1128     case OP_TRANS:
1129     case OP_TRANSR:
1130         if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
1131             && (o->op_private & OPpTRANS_USE_SVOP))
1132         {
1133 #ifdef USE_ITHREADS
1134             if (cPADOPo->op_padix > 0) {
1135                 pad_swipe(cPADOPo->op_padix, TRUE);
1136                 cPADOPo->op_padix = 0;
1137             }
1138 #else
1139             SvREFCNT_dec(cSVOPo->op_sv);
1140             cSVOPo->op_sv = NULL;
1141 #endif
1142         }
1143         else {
1144             PerlMemShared_free(cPVOPo->op_pv);
1145             cPVOPo->op_pv = NULL;
1146         }
1147         break;
1148     case OP_SUBST:
1149         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
1150         goto clear_pmop;
1151 
1152     case OP_SPLIT:
1153         if (     (o->op_private & OPpSPLIT_ASSIGN) /* @array  = split */
1154             && !(o->op_flags & OPf_STACKED))       /* @{expr} = split */
1155         {
1156             if (o->op_private & OPpSPLIT_LEX)
1157                 pad_free(cPMOPo->op_pmreplrootu.op_pmtargetoff);
1158             else
1159 #ifdef USE_ITHREADS
1160                 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
1161 #else
1162                 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
1163 #endif
1164         }
1165         /* FALLTHROUGH */
1166     case OP_MATCH:
1167     case OP_QR:
1168     clear_pmop:
1169         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
1170             op_free(cPMOPo->op_code_list);
1171         cPMOPo->op_code_list = NULL;
1172         forget_pmop(cPMOPo);
1173         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
1174         /* we use the same protection as the "SAFE" version of the PM_ macros
1175          * here since sv_clean_all might release some PMOPs
1176          * after PL_regex_padav has been cleared
1177          * and the clearing of PL_regex_padav needs to
1178          * happen before sv_clean_all
1179          */
1180 #ifdef USE_ITHREADS
1181         if(PL_regex_pad) {        /* We could be in destruction */
1182             const IV offset = (cPMOPo)->op_pmoffset;
1183             ReREFCNT_dec(PM_GETRE(cPMOPo));
1184             PL_regex_pad[offset] = &PL_sv_undef;
1185             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
1186                            sizeof(offset));
1187         }
1188 #else
1189         ReREFCNT_dec(PM_GETRE(cPMOPo));
1190         PM_SETRE(cPMOPo, NULL);
1191 #endif
1192 
1193         break;
1194 
1195     case OP_ARGCHECK:
1196         PerlMemShared_free(cUNOP_AUXo->op_aux);
1197         break;
1198 
1199     case OP_MULTICONCAT:
1200         {
1201             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1202             /* aux[PERL_MULTICONCAT_IX_PLAIN_PV] and/or
1203              * aux[PERL_MULTICONCAT_IX_UTF8_PV] point to plain and/or
1204              * utf8 shared strings */
1205             char *p1 = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
1206             char *p2 = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
1207             if (p1)
1208                 PerlMemShared_free(p1);
1209             if (p2 && p1 != p2)
1210                 PerlMemShared_free(p2);
1211             PerlMemShared_free(aux);
1212         }
1213         break;
1214 
1215     case OP_MULTIDEREF:
1216         {
1217             UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1218             UV actions = items->uv;
1219             bool last = 0;
1220             bool is_hash = FALSE;
1221 
1222             while (!last) {
1223                 switch (actions & MDEREF_ACTION_MASK) {
1224 
1225                 case MDEREF_reload:
1226                     actions = (++items)->uv;
1227                     continue;
1228 
1229                 case MDEREF_HV_padhv_helem:
1230                     is_hash = TRUE;
1231                     /* FALLTHROUGH */
1232                 case MDEREF_AV_padav_aelem:
1233                     pad_free((++items)->pad_offset);
1234                     goto do_elem;
1235 
1236                 case MDEREF_HV_gvhv_helem:
1237                     is_hash = TRUE;
1238                     /* FALLTHROUGH */
1239                 case MDEREF_AV_gvav_aelem:
1240 #ifdef USE_ITHREADS
1241                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1242 #else
1243                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1244 #endif
1245                     goto do_elem;
1246 
1247                 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
1248                     is_hash = TRUE;
1249                     /* FALLTHROUGH */
1250                 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
1251 #ifdef USE_ITHREADS
1252                     S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1253 #else
1254                     S_op_clear_gv(aTHX_ o, &((++items)->sv));
1255 #endif
1256                     goto do_vivify_rv2xv_elem;
1257 
1258                 case MDEREF_HV_padsv_vivify_rv2hv_helem:
1259                     is_hash = TRUE;
1260                     /* FALLTHROUGH */
1261                 case MDEREF_AV_padsv_vivify_rv2av_aelem:
1262                     pad_free((++items)->pad_offset);
1263                     goto do_vivify_rv2xv_elem;
1264 
1265                 case MDEREF_HV_pop_rv2hv_helem:
1266                 case MDEREF_HV_vivify_rv2hv_helem:
1267                     is_hash = TRUE;
1268                     /* FALLTHROUGH */
1269                 do_vivify_rv2xv_elem:
1270                 case MDEREF_AV_pop_rv2av_aelem:
1271                 case MDEREF_AV_vivify_rv2av_aelem:
1272                 do_elem:
1273                     switch (actions & MDEREF_INDEX_MASK) {
1274                     case MDEREF_INDEX_none:
1275                         last = 1;
1276                         break;
1277                     case MDEREF_INDEX_const:
1278                         if (is_hash) {
1279 #ifdef USE_ITHREADS
1280                             /* see RT #15654 */
1281                             pad_swipe((++items)->pad_offset, 1);
1282 #else
1283                             SvREFCNT_dec((++items)->sv);
1284 #endif
1285                         }
1286                         else
1287                             items++;
1288                         break;
1289                     case MDEREF_INDEX_padsv:
1290                         pad_free((++items)->pad_offset);
1291                         break;
1292                     case MDEREF_INDEX_gvsv:
1293 #ifdef USE_ITHREADS
1294                         S_op_clear_gv(aTHX_ o, &((++items)->pad_offset));
1295 #else
1296                         S_op_clear_gv(aTHX_ o, &((++items)->sv));
1297 #endif
1298                         break;
1299                     }
1300 
1301                     if (actions & MDEREF_FLAG_last)
1302                         last = 1;
1303                     is_hash = FALSE;
1304 
1305                     break;
1306 
1307                 default:
1308                     assert(0);
1309                     last = 1;
1310                     break;
1311 
1312                 } /* switch */
1313 
1314                 actions >>= MDEREF_SHIFT;
1315             } /* while */
1316 
1317             /* start of malloc is at op_aux[-1], where the length is
1318              * stored */
1319             PerlMemShared_free(cUNOP_AUXo->op_aux - 1);
1320         }
1321         break;
1322 
1323     case OP_METHSTART:
1324         {
1325             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1326             /* Every item in aux is a UV, so nothing in it to free */
1327             Safefree(aux);
1328         }
1329         break;
1330 
1331     case OP_INITFIELD:
1332         {
1333             UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
1334             /* Every item in aux is a UV, so nothing in it to free */
1335             Safefree(aux);
1336         }
1337         break;
1338     }
1339 
1340     if (o->op_targ > 0) {
1341         pad_free(o->op_targ);
1342         o->op_targ = 0;
1343     }
1344 }
1345 
1346 STATIC void
S_cop_free(pTHX_ COP * cop)1347 S_cop_free(pTHX_ COP* cop)
1348 {
1349     PERL_ARGS_ASSERT_COP_FREE;
1350 
1351     /* If called during global destruction PL_defstash might be NULL and there
1352        shouldn't be any code running that will trip over the bad cop address.
1353        This also avoids uselessly creating the AV after it's been destroyed.
1354     */
1355     if (cop->op_type == OP_DBSTATE && PL_phase != PERL_PHASE_DESTRUCT) {
1356         /* Remove the now invalid op from the line number information.
1357            This could cause a freed memory overwrite if the debugger tried to
1358            set a breakpoint on this line.
1359         */
1360         AV *av = CopFILEAVn(cop);
1361         if (av) {
1362             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
1363             if (svp && *svp != &PL_sv_undef && SvIVX(*svp) == PTR2IV(cop) ) {
1364                 (void)SvIOK_off(*svp);
1365                 SvIV_set(*svp, 0);
1366             }
1367         }
1368     }
1369     CopFILE_free(cop);
1370     if (! specialWARN(cop->cop_warnings))
1371         cop->cop_warnings = rcpv_free(cop->cop_warnings);
1372 
1373     cophh_free(CopHINTHASH_get(cop));
1374     if (PL_curcop == cop)
1375        PL_curcop = NULL;
1376 }
1377 
1378 STATIC void
S_forget_pmop(pTHX_ PMOP * const o)1379 S_forget_pmop(pTHX_ PMOP *const o)
1380 {
1381     HV * const pmstash = PmopSTASH(o);
1382 
1383     PERL_ARGS_ASSERT_FORGET_PMOP;
1384 
1385     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
1386         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
1387         if (mg) {
1388             PMOP **const array = (PMOP**) mg->mg_ptr;
1389             U32 count = mg->mg_len / sizeof(PMOP**);
1390             U32 i = count;
1391 
1392             while (i--) {
1393                 if (array[i] == o) {
1394                     /* Found it. Move the entry at the end to overwrite it.  */
1395                     array[i] = array[--count];
1396                     mg->mg_len = count * sizeof(PMOP**);
1397                     /* Could realloc smaller at this point always, but probably
1398                        not worth it. Probably worth free()ing if we're the
1399                        last.  */
1400                     if(!count) {
1401                         Safefree(mg->mg_ptr);
1402                         mg->mg_ptr = NULL;
1403                     }
1404                     break;
1405                 }
1406             }
1407         }
1408     }
1409     if (PL_curpm == o)
1410         PL_curpm = NULL;
1411 }
1412 
1413 
1414 STATIC void
S_find_and_forget_pmops(pTHX_ OP * o)1415 S_find_and_forget_pmops(pTHX_ OP *o)
1416 {
1417     OP* top_op = o;
1418 
1419     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1420 
1421     while (1) {
1422         switch (o->op_type) {
1423         case OP_SUBST:
1424         case OP_SPLIT:
1425         case OP_MATCH:
1426         case OP_QR:
1427             forget_pmop(cPMOPo);
1428         }
1429 
1430         if (o->op_flags & OPf_KIDS) {
1431             o = cUNOPo->op_first;
1432             continue;
1433         }
1434 
1435         while (1) {
1436             if (o == top_op)
1437                 return; /* at top; no parents/siblings to try */
1438             if (OpHAS_SIBLING(o)) {
1439                 o = o->op_sibparent; /* process next sibling */
1440                 break;
1441             }
1442             o = o->op_sibparent; /*try parent's next sibling */
1443         }
1444     }
1445 }
1446 
1447 
1448 /*
1449 =for apidoc op_null
1450 
1451 Neutralizes an op when it is no longer needed, but is still linked to from
1452 other ops.
1453 
1454 =cut
1455 */
1456 
1457 void
Perl_op_null(pTHX_ OP * o)1458 Perl_op_null(pTHX_ OP *o)
1459 {
1460 
1461     PERL_ARGS_ASSERT_OP_NULL;
1462 
1463     if (o->op_type == OP_NULL)
1464         return;
1465     op_clear(o);
1466     o->op_targ = o->op_type;
1467     OpTYPE_set(o, OP_NULL);
1468 }
1469 
1470 /*
1471 =for apidoc op_refcnt_lock
1472 
1473 Implements the C<OP_REFCNT_LOCK> macro which you should use instead.
1474 
1475 =cut
1476 */
1477 
1478 void
Perl_op_refcnt_lock(pTHX)1479 Perl_op_refcnt_lock(pTHX)
1480   PERL_TSA_ACQUIRE(PL_op_mutex)
1481 {
1482     PERL_UNUSED_CONTEXT;
1483     OP_REFCNT_LOCK;
1484 }
1485 
1486 /*
1487 =for apidoc op_refcnt_unlock
1488 
1489 Implements the C<OP_REFCNT_UNLOCK> macro which you should use instead.
1490 
1491 =cut
1492 */
1493 
1494 void
Perl_op_refcnt_unlock(pTHX)1495 Perl_op_refcnt_unlock(pTHX)
1496   PERL_TSA_RELEASE(PL_op_mutex)
1497 {
1498     PERL_UNUSED_CONTEXT;
1499     OP_REFCNT_UNLOCK;
1500 }
1501 
1502 
1503 /*
1504 =for apidoc op_sibling_splice
1505 
1506 A general function for editing the structure of an existing chain of
1507 op_sibling nodes.  By analogy with the perl-level C<splice()> function, allows
1508 you to delete zero or more sequential nodes, replacing them with zero or
1509 more different nodes.  Performs the necessary op_first/op_last
1510 housekeeping on the parent node and op_sibling manipulation on the
1511 children.  The last deleted node will be marked as the last node by
1512 updating the op_sibling/op_sibparent or op_moresib field as appropriate.
1513 
1514 Note that op_next is not manipulated, and nodes are not freed; that is the
1515 responsibility of the caller.  It also won't create a new list op for an
1516 empty list etc; use higher-level functions like op_append_elem() for that.
1517 
1518 C<parent> is the parent node of the sibling chain. It may passed as C<NULL> if
1519 the splicing doesn't affect the first or last op in the chain.
1520 
1521 C<start> is the node preceding the first node to be spliced.  Node(s)
1522 following it will be deleted, and ops will be inserted after it.  If it is
1523 C<NULL>, the first node onwards is deleted, and nodes are inserted at the
1524 beginning.
1525 
1526 C<del_count> is the number of nodes to delete.  If zero, no nodes are deleted.
1527 If -1 or greater than or equal to the number of remaining kids, all
1528 remaining kids are deleted.
1529 
1530 C<insert> is the first of a chain of nodes to be inserted in place of the nodes.
1531 If C<NULL>, no nodes are inserted.
1532 
1533 The head of the chain of deleted ops is returned, or C<NULL> if no ops were
1534 deleted.
1535 
1536 For example:
1537 
1538     action                    before      after         returns
1539     ------                    -----       -----         -------
1540 
1541                               P           P
1542     splice(P, A, 2, X-Y-Z)    |           |             B-C
1543                               A-B-C-D     A-X-Y-Z-D
1544 
1545                               P           P
1546     splice(P, NULL, 1, X-Y)   |           |             A
1547                               A-B-C-D     X-Y-B-C-D
1548 
1549                               P           P
1550     splice(P, NULL, 3, NULL)  |           |             A-B-C
1551                               A-B-C-D     D
1552 
1553                               P           P
1554     splice(P, B, 0, X-Y)      |           |             NULL
1555                               A-B-C-D     A-B-X-Y-C-D
1556 
1557 
1558 For lower-level direct manipulation of C<op_sibparent> and C<op_moresib>,
1559 see C<L</OpMORESIB_set>>, C<L</OpLASTSIB_set>>, C<L</OpMAYBESIB_set>>.
1560 
1561 =cut
1562 */
1563 
1564 OP *
Perl_op_sibling_splice(OP * parent,OP * start,int del_count,OP * insert)1565 Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
1566 {
1567     OP *first;
1568     OP *rest;
1569     OP *last_del = NULL;
1570     OP *last_ins = NULL;
1571 
1572     if (start)
1573         first = OpSIBLING(start);
1574     else if (!parent)
1575         goto no_parent;
1576     else
1577         first = cLISTOPx(parent)->op_first;
1578 
1579     assert(del_count >= -1);
1580 
1581     if (del_count && first) {
1582         last_del = first;
1583         while (--del_count && OpHAS_SIBLING(last_del))
1584             last_del = OpSIBLING(last_del);
1585         rest = OpSIBLING(last_del);
1586         OpLASTSIB_set(last_del, NULL);
1587     }
1588     else
1589         rest = first;
1590 
1591     if (insert) {
1592         last_ins = insert;
1593         while (OpHAS_SIBLING(last_ins))
1594             last_ins = OpSIBLING(last_ins);
1595         OpMAYBESIB_set(last_ins, rest, NULL);
1596     }
1597     else
1598         insert = rest;
1599 
1600     if (start) {
1601         OpMAYBESIB_set(start, insert, NULL);
1602     }
1603     else {
1604         assert(parent);
1605         cLISTOPx(parent)->op_first = insert;
1606         if (insert)
1607             parent->op_flags |= OPf_KIDS;
1608         else
1609             parent->op_flags &= ~OPf_KIDS;
1610     }
1611 
1612     if (!rest) {
1613         /* update op_last etc */
1614         U32 type;
1615         OP *lastop;
1616 
1617         if (!parent)
1618             goto no_parent;
1619 
1620         /* ought to use OP_CLASS(parent) here, but that can't handle
1621          * ex-foo OP_NULL ops. Also note that XopENTRYCUSTOM() can't
1622          * either */
1623         type = parent->op_type;
1624         if (type == OP_CUSTOM) {
1625             dTHX;
1626             type = XopENTRYCUSTOM(parent, xop_class);
1627         }
1628         else {
1629             if (type == OP_NULL)
1630                 type = parent->op_targ;
1631             type = PL_opargs[type] & OA_CLASS_MASK;
1632         }
1633 
1634         lastop = last_ins ? last_ins : start ? start : NULL;
1635         if (   type == OA_BINOP
1636             || type == OA_LISTOP
1637             || type == OA_PMOP
1638             || type == OA_LOOP
1639         )
1640             cLISTOPx(parent)->op_last = lastop;
1641 
1642         if (lastop)
1643             OpLASTSIB_set(lastop, parent);
1644     }
1645     return last_del ? first : NULL;
1646 
1647   no_parent:
1648     Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
1649 }
1650 
1651 /*
1652 =for apidoc op_parent
1653 
1654 Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
1655 
1656 =cut
1657 */
1658 
1659 OP *
Perl_op_parent(OP * o)1660 Perl_op_parent(OP *o)
1661 {
1662     PERL_ARGS_ASSERT_OP_PARENT;
1663     while (OpHAS_SIBLING(o))
1664         o = OpSIBLING(o);
1665     return o->op_sibparent;
1666 }
1667 
1668 /* replace the sibling following start with a new UNOP, which becomes
1669  * the parent of the original sibling; e.g.
1670  *
1671  *  op_sibling_newUNOP(P, A, unop-args...)
1672  *
1673  *  P              P
1674  *  |      becomes |
1675  *  A-B-C          A-U-C
1676  *                   |
1677  *                   B
1678  *
1679  * where U is the new UNOP.
1680  *
1681  * parent and start args are the same as for op_sibling_splice();
1682  * type and flags args are as newUNOP().
1683  *
1684  * Returns the new UNOP.
1685  */
1686 
1687 STATIC OP *
S_op_sibling_newUNOP(pTHX_ OP * parent,OP * start,I32 type,I32 flags)1688 S_op_sibling_newUNOP(pTHX_ OP *parent, OP *start, I32 type, I32 flags)
1689 {
1690     OP *kid, *newop;
1691 
1692     kid = op_sibling_splice(parent, start, 1, NULL);
1693     newop = newUNOP(type, flags, kid);
1694     op_sibling_splice(parent, start, 0, newop);
1695     return newop;
1696 }
1697 
1698 
1699 /* lowest-level newLOGOP-style function - just allocates and populates
1700  * the struct. Higher-level stuff should be done by S_new_logop() /
1701  * newLOGOP(). This function exists mainly to avoid op_first assignment
1702  * being spread throughout this file.
1703  */
1704 
1705 LOGOP *
Perl_alloc_LOGOP(pTHX_ I32 type,OP * first,OP * other)1706 Perl_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
1707 {
1708     LOGOP *logop;
1709     OP *kid = first;
1710     NewOp(1101, logop, 1, LOGOP);
1711     OpTYPE_set(logop, type);
1712     logop->op_first = first;
1713     logop->op_other = other;
1714     if (first)
1715         logop->op_flags = OPf_KIDS;
1716     while (kid && OpHAS_SIBLING(kid))
1717         kid = OpSIBLING(kid);
1718     if (kid)
1719         OpLASTSIB_set(kid, (OP*)logop);
1720     return logop;
1721 }
1722 
1723 
1724 /* Contextualizers */
1725 
1726 /*
1727 =for apidoc op_contextualize
1728 
1729 Applies a syntactic context to an op tree representing an expression.
1730 C<o> is the op tree, and C<context> must be C<G_SCALAR>, C<G_LIST>,
1731 or C<G_VOID> to specify the context to apply.  The modified op tree
1732 is returned.
1733 
1734 =cut
1735 */
1736 
1737 OP *
Perl_op_contextualize(pTHX_ OP * o,I32 context)1738 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1739 {
1740     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1741     switch (context) {
1742         case G_SCALAR: return scalar(o);
1743         case G_LIST:   return list(o);
1744         case G_VOID:   return scalarvoid(o);
1745         default:
1746             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1747                        (long) context);
1748     }
1749 }
1750 
1751 /*
1752 
1753 =for apidoc op_linklist
1754 This function is the implementation of the L</LINKLIST> macro.  It should
1755 not be called directly.
1756 
1757 =cut
1758 */
1759 
1760 
1761 OP *
Perl_op_linklist(pTHX_ OP * o)1762 Perl_op_linklist(pTHX_ OP *o)
1763 {
1764 
1765     OP **prevp;
1766     OP *kid;
1767     OP * top_op = o;
1768 
1769     PERL_ARGS_ASSERT_OP_LINKLIST;
1770 
1771     while (1) {
1772         /* Descend down the tree looking for any unprocessed subtrees to
1773          * do first */
1774         if (!o->op_next) {
1775             if (o->op_flags & OPf_KIDS) {
1776                 o = cUNOPo->op_first;
1777                 continue;
1778             }
1779             o->op_next = o; /* leaf node; link to self initially */
1780         }
1781 
1782         /* if we're at the top level, there either weren't any children
1783          * to process, or we've worked our way back to the top. */
1784         if (o == top_op)
1785             return o->op_next;
1786 
1787         /* o is now processed. Next, process any sibling subtrees */
1788 
1789         if (OpHAS_SIBLING(o)) {
1790             o = OpSIBLING(o);
1791             continue;
1792         }
1793 
1794         /* Done all the subtrees at this level. Go back up a level and
1795          * link the parent in with all its (processed) children.
1796          */
1797 
1798         o = o->op_sibparent;
1799         assert(!o->op_next);
1800         prevp = &(o->op_next);
1801         kid   = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
1802         while (kid) {
1803             *prevp = kid->op_next;
1804             prevp = &(kid->op_next);
1805             kid = OpSIBLING(kid);
1806         }
1807         *prevp = o;
1808     }
1809 }
1810 
1811 
1812 static OP *
S_scalarkids(pTHX_ OP * o)1813 S_scalarkids(pTHX_ OP *o)
1814 {
1815     if (o && o->op_flags & OPf_KIDS) {
1816         OP *kid;
1817         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
1818             scalar(kid);
1819     }
1820     return o;
1821 }
1822 
1823 STATIC OP *
S_scalarboolean(pTHX_ OP * o)1824 S_scalarboolean(pTHX_ OP *o)
1825 {
1826     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1827 
1828     if ((o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST &&
1829          !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) ||
1830         (o->op_type == OP_NOT     && cUNOPo->op_first->op_type == OP_SASSIGN &&
1831          cBINOPx(cUNOPo->op_first)->op_first->op_type == OP_CONST &&
1832          !(cBINOPx(cUNOPo->op_first)->op_first->op_flags & OPf_SPECIAL))) {
1833         if (ckWARN(WARN_SYNTAX)) {
1834             const line_t oldline = CopLINE(PL_curcop);
1835 
1836             if (PL_parser && PL_parser->copline != NOLINE) {
1837                 /* This ensures that warnings are reported at the first line
1838                    of the conditional, not the last.  */
1839                 CopLINE_set(PL_curcop, PL_parser->copline);
1840             }
1841             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1842             CopLINE_set(PL_curcop, oldline);
1843         }
1844     }
1845     return scalar(o);
1846 }
1847 
1848 static SV *
S_op_varname_subscript(pTHX_ const OP * o,int subscript_type)1849 S_op_varname_subscript(pTHX_ const OP *o, int subscript_type)
1850 {
1851     assert(o);
1852     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1853            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1854     {
1855         const char funny  = o->op_type == OP_PADAV
1856                          || o->op_type == OP_RV2AV ? '@' : '%';
1857         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1858             GV *gv;
1859             if (cUNOPo->op_first->op_type != OP_GV
1860              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1861                 return NULL;
1862             return varname(gv, funny, 0, NULL, 0, subscript_type);
1863         }
1864         return
1865             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, subscript_type);
1866     }
1867 }
1868 
1869 SV *
Perl_op_varname(pTHX_ const OP * o)1870 Perl_op_varname(pTHX_ const OP *o)
1871 {
1872     PERL_ARGS_ASSERT_OP_VARNAME;
1873 
1874     return S_op_varname_subscript(aTHX_ o, 1);
1875 }
1876 
1877 /*
1878 
1879 Warns that an access of a single element from a named container variable in
1880 scalar context might not be what the programmer wanted. The container
1881 variable's (sigiled, full) name is given by C<name>, and the key to access
1882 it is given by the C<SVOP_sv> of the C<OP_CONST> op given by C<o>.
1883 C<is_hash> selects whether it prints using {KEY} or [KEY] brackets.
1884 
1885 C<is_slice> selects between two different messages used in different places.
1886  */
1887 void
Perl_warn_elem_scalar_context(pTHX_ const OP * o,SV * name,bool is_hash,bool is_slice)1888 Perl_warn_elem_scalar_context(pTHX_ const OP *o, SV *name, bool is_hash, bool is_slice)
1889 {
1890     PERL_ARGS_ASSERT_WARN_ELEM_SCALAR_CONTEXT;
1891 
1892     SV *keysv = NULL;
1893     const char *keypv = NULL;
1894 
1895     const char lbrack = is_hash ? '{' : '[';
1896     const char rbrack = is_hash ? '}' : ']';
1897 
1898     if (o->op_type == OP_CONST) {
1899         keysv = cSVOPo_sv;
1900         if (SvPOK(keysv)) {
1901             SV *sv = keysv;
1902             keysv = sv_newmortal();
1903             pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1904                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1905         }
1906         else if (!SvOK(keysv))
1907             keypv = "undef";
1908     }
1909     else keypv = "...";
1910 
1911     assert(SvPOK(name));
1912     sv_chop(name,SvPVX(name)+1);
1913 
1914     const char *msg;
1915 
1916     if (keypv) {
1917         msg = is_slice ?
1918             /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1919             PERL_DIAG_WARN_SYNTAX(
1920                 "Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c") :
1921             /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1922             PERL_DIAG_WARN_SYNTAX(
1923                 "%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c");
1924 
1925         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1926                 SVfARG(name), lbrack, keypv, rbrack,
1927                 SVfARG(name), lbrack, keypv, rbrack);
1928     }
1929     else {
1930         msg = is_slice ?
1931             /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1932             PERL_DIAG_WARN_SYNTAX(
1933                 "Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c") :
1934             /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1935             PERL_DIAG_WARN_SYNTAX(
1936                 "%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c");
1937 
1938         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
1939                 SVfARG(name), lbrack, SVfARG(keysv), rbrack,
1940                 SVfARG(name), lbrack, SVfARG(keysv), rbrack);
1941     }
1942 }
1943 
1944 
1945 /* apply scalar context to the o subtree */
1946 
1947 OP *
Perl_scalar(pTHX_ OP * o)1948 Perl_scalar(pTHX_ OP *o)
1949 {
1950     OP * top_op = o;
1951 
1952     while (1) {
1953         OP *next_kid = NULL; /* what op (if any) to process next */
1954         OP *kid;
1955 
1956         /* assumes no premature commitment */
1957         if (!o || (PL_parser && PL_parser->error_count)
1958              || (o->op_flags & OPf_WANT)
1959              || o->op_type == OP_RETURN)
1960         {
1961             goto do_next;
1962         }
1963 
1964         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1965 
1966         switch (o->op_type) {
1967         case OP_REPEAT:
1968             scalar(cBINOPo->op_first);
1969             /* convert what initially looked like a list repeat into a
1970              * scalar repeat, e.g. $s = (1) x $n
1971              */
1972             if (o->op_private & OPpREPEAT_DOLIST) {
1973                 kid = cLISTOPx(cUNOPo->op_first)->op_first;
1974                 assert(kid->op_type == OP_PUSHMARK);
1975                 if (OpHAS_SIBLING(kid) && !OpHAS_SIBLING(OpSIBLING(kid))) {
1976                     op_null(cLISTOPx(cUNOPo->op_first)->op_first);
1977                     o->op_private &=~ OPpREPEAT_DOLIST;
1978                 }
1979             }
1980             break;
1981 
1982         case OP_OR:
1983         case OP_AND:
1984         case OP_COND_EXPR:
1985             /* impose scalar context on everything except the condition */
1986             next_kid = OpSIBLING(cUNOPo->op_first);
1987             break;
1988 
1989         default:
1990             if (o->op_flags & OPf_KIDS)
1991                 next_kid = cUNOPo->op_first; /* do all kids */
1992             break;
1993 
1994         /* the children of these ops are usually a list of statements,
1995          * except the leaves, whose first child is a corresponding enter
1996          */
1997         case OP_SCOPE:
1998         case OP_LINESEQ:
1999         case OP_LIST:
2000             kid = cLISTOPo->op_first;
2001             goto do_kids;
2002         case OP_LEAVE:
2003         case OP_LEAVETRY:
2004             kid = cLISTOPo->op_first;
2005             scalar(kid);
2006             kid = OpSIBLING(kid);
2007         do_kids:
2008             while (kid) {
2009                 OP *sib = OpSIBLING(kid);
2010                 /* Apply void context to all kids except the last, which
2011                  * is scalar (ignoring a trailing ex-nextstate in determining
2012                  * if it's the last kid). E.g.
2013                  *      $scalar = do { void; void; scalar }
2014                  * Except that 'when's are always scalar, e.g.
2015                  *      $scalar = do { given(..) {
2016                     *                 when (..) { scalar }
2017                     *                 when (..) { scalar }
2018                     *                 ...
2019                     *                }}
2020                     */
2021                 if (!sib
2022                      || (  !OpHAS_SIBLING(sib)
2023                          && sib->op_type == OP_NULL
2024                          && (   sib->op_targ == OP_NEXTSTATE
2025                              || sib->op_targ == OP_DBSTATE  )
2026                         )
2027                 )
2028                 {
2029                     /* tail call optimise calling scalar() on the last kid */
2030                     next_kid = kid;
2031                     goto do_next;
2032                 }
2033                 else if (kid->op_type == OP_LEAVEWHEN)
2034                     scalar(kid);
2035                 else
2036                     scalarvoid(kid);
2037                 kid = sib;
2038             }
2039             NOT_REACHED; /* NOTREACHED */
2040             break;
2041 
2042         case OP_SORT:
2043             Perl_ck_warner(aTHX_ packWARN(WARN_SCALAR), "Useless use of %s in scalar context", "sort");
2044             break;
2045 
2046         case OP_KVHSLICE:
2047         case OP_KVASLICE:
2048         {
2049             /* Warn about scalar context */
2050             SV *name;
2051 
2052             /* This warning can be nonsensical when there is a syntax error. */
2053             if (PL_parser && PL_parser->error_count)
2054                 break;
2055 
2056             if (!ckWARN(WARN_SYNTAX)) break;
2057 
2058             kid = cLISTOPo->op_first;
2059             kid = OpSIBLING(kid); /* get past pushmark */
2060             assert(OpSIBLING(kid));
2061             name = op_varname(OpSIBLING(kid));
2062             if (!name) /* XS module fiddling with the op tree */
2063                 break;
2064             warn_elem_scalar_context(kid, name, o->op_type == OP_KVHSLICE, false);
2065         }
2066         } /* switch */
2067 
2068         /* If next_kid is set, someone in the code above wanted us to process
2069          * that kid and all its remaining siblings.  Otherwise, work our way
2070          * back up the tree */
2071       do_next:
2072         while (!next_kid) {
2073             if (o == top_op)
2074                 return top_op; /* at top; no parents/siblings to try */
2075             if (OpHAS_SIBLING(o))
2076                 next_kid = o->op_sibparent;
2077             else {
2078                 o = o->op_sibparent; /*try parent's next sibling */
2079                 switch (o->op_type) {
2080                 case OP_SCOPE:
2081                 case OP_LINESEQ:
2082                 case OP_LIST:
2083                 case OP_LEAVE:
2084                 case OP_LEAVETRY:
2085                     /* should really restore PL_curcop to its old value, but
2086                      * setting it to PL_compiling is better than do nothing */
2087                     PL_curcop = &PL_compiling;
2088                 }
2089             }
2090         }
2091         o = next_kid;
2092     } /* while */
2093 }
2094 
2095 
2096 /* apply void context to the optree arg */
2097 
2098 OP *
Perl_scalarvoid(pTHX_ OP * arg)2099 Perl_scalarvoid(pTHX_ OP *arg)
2100 {
2101     OP *kid;
2102     SV* sv;
2103     OP *o = arg;
2104 
2105     PERL_ARGS_ASSERT_SCALARVOID;
2106 
2107     while (1) {
2108         U8 want;
2109         SV *useless_sv = NULL;
2110         const char* useless = NULL;
2111         OP * next_kid = NULL;
2112 
2113         if (o->op_type == OP_NEXTSTATE
2114             || o->op_type == OP_DBSTATE
2115             || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
2116                                           || o->op_targ == OP_DBSTATE)))
2117             PL_curcop = (COP*)o;                /* for warning below */
2118 
2119         /* assumes no premature commitment */
2120         want = o->op_flags & OPf_WANT;
2121         if ((want && want != OPf_WANT_SCALAR)
2122             || (PL_parser && PL_parser->error_count)
2123             || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
2124         {
2125             goto get_next_op;
2126         }
2127 
2128         if ((o->op_private & OPpTARGET_MY)
2129             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2130         {
2131             /* newASSIGNOP has already applied scalar context, which we
2132                leave, as if this op is inside SASSIGN.  */
2133             goto get_next_op;
2134         }
2135 
2136         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
2137 
2138         switch (o->op_type) {
2139         default:
2140             if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
2141                 break;
2142             /* FALLTHROUGH */
2143         case OP_REPEAT:
2144             if (o->op_flags & OPf_STACKED)
2145                 break;
2146             if (o->op_type == OP_REPEAT)
2147                 scalar(cBINOPo->op_first);
2148             goto func_ops;
2149         case OP_CONCAT:
2150             if ((o->op_flags & OPf_STACKED) &&
2151                     !(o->op_private & OPpCONCAT_NESTED))
2152                 break;
2153             goto func_ops;
2154         case OP_SUBSTR:
2155             if (o->op_private == 4)
2156                 break;
2157             /* FALLTHROUGH */
2158         case OP_WANTARRAY:
2159         case OP_GV:
2160         case OP_SMARTMATCH:
2161         case OP_AV2ARYLEN:
2162         case OP_REF:
2163         case OP_REFGEN:
2164         case OP_SREFGEN:
2165         case OP_ANONCODE:
2166         case OP_DEFINED:
2167         case OP_HEX:
2168         case OP_OCT:
2169         case OP_LENGTH:
2170         case OP_VEC:
2171         case OP_INDEX:
2172         case OP_RINDEX:
2173         case OP_SPRINTF:
2174         case OP_KVASLICE:
2175         case OP_KVHSLICE:
2176         case OP_UNPACK:
2177         case OP_PACK:
2178         case OP_JOIN:
2179         case OP_LSLICE:
2180         case OP_ANONLIST:
2181         case OP_ANONHASH:
2182         case OP_SORT:
2183         case OP_REVERSE:
2184         case OP_RANGE:
2185         case OP_FLIP:
2186         case OP_FLOP:
2187         case OP_CALLER:
2188         case OP_FILENO:
2189         case OP_EOF:
2190         case OP_TELL:
2191         case OP_GETSOCKNAME:
2192         case OP_GETPEERNAME:
2193         case OP_READLINK:
2194         case OP_TELLDIR:
2195         case OP_GETPPID:
2196         case OP_GETPGRP:
2197         case OP_GETPRIORITY:
2198         case OP_TIME:
2199         case OP_TMS:
2200         case OP_LOCALTIME:
2201         case OP_GMTIME:
2202         case OP_GHBYNAME:
2203         case OP_GHBYADDR:
2204         case OP_GHOSTENT:
2205         case OP_GNBYNAME:
2206         case OP_GNBYADDR:
2207         case OP_GNETENT:
2208         case OP_GPBYNAME:
2209         case OP_GPBYNUMBER:
2210         case OP_GPROTOENT:
2211         case OP_GSBYNAME:
2212         case OP_GSBYPORT:
2213         case OP_GSERVENT:
2214         case OP_GPWNAM:
2215         case OP_GPWUID:
2216         case OP_GGRNAM:
2217         case OP_GGRGID:
2218         case OP_GETLOGIN:
2219         case OP_PROTOTYPE:
2220         case OP_RUNCV:
2221         func_ops:
2222             useless = OP_DESC(o);
2223             break;
2224 
2225         case OP_GVSV:
2226         case OP_PADSV:
2227         case OP_PADAV:
2228         case OP_PADHV:
2229         case OP_PADANY:
2230         case OP_AELEM:
2231         case OP_AELEMFAST:
2232         case OP_AELEMFAST_LEX:
2233         case OP_ASLICE:
2234         case OP_HELEM:
2235         case OP_HSLICE:
2236             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
2237                 /* Otherwise it's "Useless use of grep iterator" */
2238                 useless = OP_DESC(o);
2239             break;
2240 
2241         case OP_SPLIT:
2242             if (!(o->op_private & OPpSPLIT_ASSIGN))
2243                 useless = OP_DESC(o);
2244             break;
2245 
2246         case OP_NOT:
2247             kid = cUNOPo->op_first;
2248             if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
2249                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
2250                 goto func_ops;
2251             }
2252             useless = "negative pattern binding (!~)";
2253             break;
2254 
2255         case OP_SUBST:
2256             if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
2257                 useless = "non-destructive substitution (s///r)";
2258             break;
2259 
2260         case OP_TRANSR:
2261             useless = "non-destructive transliteration (tr///r)";
2262             break;
2263 
2264         case OP_RV2GV:
2265         case OP_RV2SV:
2266         case OP_RV2AV:
2267         case OP_RV2HV:
2268             if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
2269                 (!OpHAS_SIBLING(o) || OpSIBLING(o)->op_type != OP_READLINE))
2270                 useless = "a variable";
2271             break;
2272 
2273         case OP_CONST:
2274             sv = cSVOPo_sv;
2275             if (cSVOPo->op_private & OPpCONST_STRICT)
2276                 no_bareword_allowed(o);
2277             else {
2278                 if (ckWARN(WARN_VOID)) {
2279                     NV nv;
2280                     /* don't warn on optimised away booleans, eg
2281                      * use constant Foo, 5; Foo || print; */
2282                     if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
2283                         useless = NULL;
2284                     /* the constants 0 and 1 are permitted as they are
2285                        conventionally used as dummies in constructs like
2286                        1 while some_condition_with_side_effects;  */
2287                     else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
2288                         useless = NULL;
2289                     else if (SvPOK(sv)) {
2290                         SV * const dsv = newSVpvs("");
2291                         useless_sv
2292                             = Perl_newSVpvf(aTHX_
2293                                             "a constant (%s)",
2294                                             pv_pretty(dsv, SvPVX_const(sv),
2295                                                       SvCUR(sv), 32, NULL, NULL,
2296                                                       PERL_PV_PRETTY_DUMP
2297                                                       | PERL_PV_ESCAPE_NOCLEAR
2298                                                       | PERL_PV_ESCAPE_UNI_DETECT));
2299                         SvREFCNT_dec_NN(dsv);
2300                     }
2301                     else if (SvOK(sv)) {
2302                         useless_sv = Perl_newSVpvf(aTHX_ "a constant (%" SVf ")", SVfARG(sv));
2303                     }
2304                     else
2305                         useless = "a constant (undef)";
2306                 }
2307             }
2308             op_null(o);         /* don't execute or even remember it */
2309             break;
2310 
2311         case OP_POSTINC:
2312             OpTYPE_set(o, OP_PREINC);  /* pre-increment is faster */
2313             break;
2314 
2315         case OP_POSTDEC:
2316             OpTYPE_set(o, OP_PREDEC);  /* pre-decrement is faster */
2317             break;
2318 
2319         case OP_I_POSTINC:
2320             OpTYPE_set(o, OP_I_PREINC);        /* pre-increment is faster */
2321             break;
2322 
2323         case OP_I_POSTDEC:
2324             OpTYPE_set(o, OP_I_PREDEC);        /* pre-decrement is faster */
2325             break;
2326 
2327         case OP_SASSIGN: {
2328             OP *rv2gv;
2329             UNOP *refgen, *rv2cv;
2330             LISTOP *exlist;
2331 
2332             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
2333                 break;
2334 
2335             rv2gv = cBINOPo->op_last;
2336             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
2337                 break;
2338 
2339             refgen = cUNOPx(cBINOPo->op_first);
2340 
2341             if (!refgen || (refgen->op_type != OP_REFGEN
2342                             && refgen->op_type != OP_SREFGEN))
2343                 break;
2344 
2345             exlist = cLISTOPx(refgen->op_first);
2346             if (!exlist || exlist->op_type != OP_NULL
2347                 || exlist->op_targ != OP_LIST)
2348                 break;
2349 
2350             if (exlist->op_first->op_type != OP_PUSHMARK
2351                 && exlist->op_first != exlist->op_last)
2352                 break;
2353 
2354             rv2cv = cUNOPx(exlist->op_last);
2355 
2356             if (rv2cv->op_type != OP_RV2CV)
2357                 break;
2358 
2359             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
2360             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
2361             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
2362 
2363             o->op_private |= OPpASSIGN_CV_TO_GV;
2364             rv2gv->op_private |= OPpDONT_INIT_GV;
2365             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
2366 
2367             break;
2368         }
2369 
2370         case OP_AASSIGN: {
2371             inplace_aassign(o);
2372             break;
2373         }
2374 
2375         case OP_OR:
2376         case OP_AND:
2377             kid = cLOGOPo->op_first;
2378             if (kid->op_type == OP_NOT
2379                 && (kid->op_flags & OPf_KIDS)) {
2380                 if (o->op_type == OP_AND) {
2381                     OpTYPE_set(o, OP_OR);
2382                 } else {
2383                     OpTYPE_set(o, OP_AND);
2384                 }
2385                 op_null(kid);
2386             }
2387             /* FALLTHROUGH */
2388 
2389         case OP_DOR:
2390         case OP_COND_EXPR:
2391         case OP_ENTERGIVEN:
2392         case OP_ENTERWHEN:
2393             next_kid = OpSIBLING(cUNOPo->op_first);
2394         break;
2395 
2396         case OP_NULL:
2397             if (o->op_flags & OPf_STACKED)
2398                 break;
2399             /* FALLTHROUGH */
2400         case OP_NEXTSTATE:
2401         case OP_DBSTATE:
2402         case OP_ENTERTRY:
2403         case OP_ENTER:
2404             if (!(o->op_flags & OPf_KIDS))
2405                 break;
2406             /* FALLTHROUGH */
2407         case OP_SCOPE:
2408         case OP_LEAVE:
2409         case OP_LEAVETRY:
2410         case OP_LEAVELOOP:
2411         case OP_LINESEQ:
2412         case OP_LEAVEGIVEN:
2413         case OP_LEAVEWHEN:
2414         kids:
2415             next_kid = cLISTOPo->op_first;
2416             break;
2417         case OP_LIST:
2418             /* If the first kid after pushmark is something that the padrange
2419                optimisation would reject, then null the list and the pushmark.
2420             */
2421             if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
2422                 && (  !(kid = OpSIBLING(kid))
2423                       || (  kid->op_type != OP_PADSV
2424                             && kid->op_type != OP_PADAV
2425                             && kid->op_type != OP_PADHV)
2426                       || kid->op_private & ~OPpLVAL_INTRO
2427                       || !(kid = OpSIBLING(kid))
2428                       || (  kid->op_type != OP_PADSV
2429                             && kid->op_type != OP_PADAV
2430                             && kid->op_type != OP_PADHV)
2431                       || kid->op_private & ~OPpLVAL_INTRO)
2432             ) {
2433                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2434                 op_null(o); /* NULL the list */
2435             }
2436             goto kids;
2437         case OP_ENTEREVAL:
2438             scalarkids(o);
2439             break;
2440         case OP_SCALAR:
2441             scalar(o);
2442             break;
2443         }
2444 
2445         if (useless_sv) {
2446             /* mortalise it, in case warnings are fatal.  */
2447             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2448                            "Useless use of %" SVf " in void context",
2449                            SVfARG(sv_2mortal(useless_sv)));
2450         }
2451         else if (useless) {
2452             Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
2453                            "Useless use of %s in void context",
2454                            useless);
2455         }
2456 
2457       get_next_op:
2458         /* if a kid hasn't been nominated to process, continue with the
2459          * next sibling, or if no siblings left, go back to the parent's
2460          * siblings and so on
2461          */
2462         while (!next_kid) {
2463             if (o == arg)
2464                 return arg; /* at top; no parents/siblings to try */
2465             if (OpHAS_SIBLING(o))
2466                 next_kid = o->op_sibparent;
2467             else
2468                 o = o->op_sibparent; /*try parent's next sibling */
2469         }
2470         o = next_kid;
2471     }
2472     NOT_REACHED;
2473 }
2474 
2475 
2476 static OP *
S_listkids(pTHX_ OP * o)2477 S_listkids(pTHX_ OP *o)
2478 {
2479     if (o && o->op_flags & OPf_KIDS) {
2480         OP *kid;
2481         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2482             list(kid);
2483     }
2484     return o;
2485 }
2486 
2487 
2488 /* apply list context to the o subtree */
2489 
2490 OP *
Perl_list(pTHX_ OP * o)2491 Perl_list(pTHX_ OP *o)
2492 {
2493     OP * top_op = o;
2494 
2495     while (1) {
2496         OP *next_kid = NULL; /* what op (if any) to process next */
2497 
2498         OP *kid;
2499 
2500         /* assumes no premature commitment */
2501         if (!o || (o->op_flags & OPf_WANT)
2502              || (PL_parser && PL_parser->error_count)
2503              || o->op_type == OP_RETURN)
2504         {
2505             goto do_next;
2506         }
2507 
2508         if ((o->op_private & OPpTARGET_MY)
2509             && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2510         {
2511             goto do_next;				/* As if inside SASSIGN */
2512         }
2513 
2514         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2515 
2516         switch (o->op_type) {
2517         case OP_REPEAT:
2518             if (o->op_private & OPpREPEAT_DOLIST
2519              && !(o->op_flags & OPf_STACKED))
2520             {
2521                 list(cBINOPo->op_first);
2522                 kid = cBINOPo->op_last;
2523                 /* optimise away (.....) x 1 */
2524                 if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
2525                  && SvIVX(kSVOP_sv) == 1)
2526                 {
2527                     op_null(o); /* repeat */
2528                     op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
2529                     /* const (rhs): */
2530                     op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
2531                 }
2532             }
2533             break;
2534 
2535         case OP_OR:
2536         case OP_AND:
2537         case OP_COND_EXPR:
2538             /* impose list context on everything except the condition */
2539             next_kid = OpSIBLING(cUNOPo->op_first);
2540             break;
2541 
2542         default:
2543             if (!(o->op_flags & OPf_KIDS))
2544                 break;
2545             /* possibly flatten 1..10 into a constant array */
2546             if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
2547                 list(cBINOPo->op_first);
2548                 gen_constant_list(o);
2549                 goto do_next;
2550             }
2551             next_kid = cUNOPo->op_first; /* do all kids */
2552             break;
2553 
2554         case OP_LIST:
2555             if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
2556                 op_null(cUNOPo->op_first); /* NULL the pushmark */
2557                 op_null(o); /* NULL the list */
2558             }
2559             if (o->op_flags & OPf_KIDS)
2560                 next_kid = cUNOPo->op_first; /* do all kids */
2561             break;
2562 
2563         /* the children of these ops are usually a list of statements,
2564          * except the leaves, whose first child is a corresponding enter
2565          */
2566         case OP_SCOPE:
2567         case OP_LINESEQ:
2568             kid = cLISTOPo->op_first;
2569             goto do_kids;
2570         case OP_LEAVE:
2571         case OP_LEAVETRY:
2572             kid = cLISTOPo->op_first;
2573             list(kid);
2574             kid = OpSIBLING(kid);
2575         do_kids:
2576             while (kid) {
2577                 OP *sib = OpSIBLING(kid);
2578                 /* Apply void context to all kids except the last, which
2579                  * is list. E.g.
2580                  *      @a = do { void; void; list }
2581                  * Except that 'when's are always list context, e.g.
2582                  *      @a = do { given(..) {
2583                     *                 when (..) { list }
2584                     *                 when (..) { list }
2585                     *                 ...
2586                     *                }}
2587                     */
2588                 if (!sib) {
2589                     /* tail call optimise calling list() on the last kid */
2590                     next_kid = kid;
2591                     goto do_next;
2592                 }
2593                 else if (kid->op_type == OP_LEAVEWHEN)
2594                     list(kid);
2595                 else
2596                     scalarvoid(kid);
2597                 kid = sib;
2598             }
2599             NOT_REACHED; /* NOTREACHED */
2600             break;
2601 
2602         }
2603 
2604         /* If next_kid is set, someone in the code above wanted us to process
2605          * that kid and all its remaining siblings.  Otherwise, work our way
2606          * back up the tree */
2607       do_next:
2608         while (!next_kid) {
2609             if (o == top_op)
2610                 return top_op; /* at top; no parents/siblings to try */
2611             if (OpHAS_SIBLING(o))
2612                 next_kid = o->op_sibparent;
2613             else {
2614                 o = o->op_sibparent; /*try parent's next sibling */
2615                 switch (o->op_type) {
2616                 case OP_SCOPE:
2617                 case OP_LINESEQ:
2618                 case OP_LIST:
2619                 case OP_LEAVE:
2620                 case OP_LEAVETRY:
2621                     /* should really restore PL_curcop to its old value, but
2622                      * setting it to PL_compiling is better than do nothing */
2623                     PL_curcop = &PL_compiling;
2624                 }
2625             }
2626 
2627 
2628         }
2629         o = next_kid;
2630     } /* while */
2631 }
2632 
2633 /* apply void context to non-final ops of a sequence */
2634 
2635 static OP *
S_voidnonfinal(pTHX_ OP * o)2636 S_voidnonfinal(pTHX_ OP *o)
2637 {
2638     if (o) {
2639         const OPCODE type = o->op_type;
2640 
2641         if (type == OP_LINESEQ || type == OP_SCOPE ||
2642             type == OP_LEAVE || type == OP_LEAVETRY)
2643         {
2644             OP *kid = cLISTOPo->op_first, *sib;
2645             if(type == OP_LEAVE) {
2646                 /* Don't put the OP_ENTER in void context */
2647                 assert(kid->op_type == OP_ENTER);
2648                 kid = OpSIBLING(kid);
2649             }
2650             for (; kid; kid = sib) {
2651                 if ((sib = OpSIBLING(kid))
2652                  && (  OpHAS_SIBLING(sib) || sib->op_type != OP_NULL
2653                     || (  sib->op_targ != OP_NEXTSTATE
2654                        && sib->op_targ != OP_DBSTATE  )))
2655                 {
2656                     scalarvoid(kid);
2657                 }
2658             }
2659             PL_curcop = &PL_compiling;
2660         }
2661         o->op_flags &= ~OPf_PARENS;
2662         if (PL_hints & HINT_BLOCK_SCOPE)
2663             o->op_flags |= OPf_PARENS;
2664     }
2665     else
2666         o = newOP(OP_STUB, 0);
2667     return o;
2668 }
2669 
2670 STATIC OP *
S_modkids(pTHX_ OP * o,I32 type)2671 S_modkids(pTHX_ OP *o, I32 type)
2672 {
2673     if (o && o->op_flags & OPf_KIDS) {
2674         OP *kid;
2675         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
2676             op_lvalue(kid, type);
2677     }
2678     return o;
2679 }
2680 
2681 
2682 /* for a helem/hslice/kvslice, if its a fixed hash, croak on invalid
2683  * const fields. Also, convert CONST keys to HEK-in-SVs.
2684  * rop    is the op that retrieves the hash;
2685  * key_op is the first key
2686  * real   if false, only check (and possibly croak); don't update op
2687  */
2688 
2689 void
Perl_check_hash_fields_and_hekify(pTHX_ UNOP * rop,SVOP * key_op,int real)2690 Perl_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op, int real)
2691 {
2692     PADNAME *lexname;
2693     GV **fields;
2694     bool check_fields;
2695 
2696     /* find the padsv corresponding to $lex->{} or @{$lex}{} */
2697     if (rop) {
2698         if (rop->op_first->op_type == OP_PADSV)
2699             /* @$hash{qw(keys here)} */
2700             rop = cUNOPx(rop->op_first);
2701         else {
2702             /* @{$hash}{qw(keys here)} */
2703             if (rop->op_first->op_type == OP_SCOPE
2704                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2705                 {
2706                     rop = cUNOPx(cLISTOPx(rop->op_first)->op_last);
2707                 }
2708             else
2709                 rop = NULL;
2710         }
2711     }
2712 
2713     lexname = NULL; /* just to silence compiler warnings */
2714     fields  = NULL; /* just to silence compiler warnings */
2715 
2716     check_fields =
2717             rop
2718          && (lexname = padnamelist_fetch(PL_comppad_name, rop->op_targ),
2719              PadnameHasTYPE(lexname))
2720          && (fields = (GV**)hv_fetchs(PadnameTYPE(lexname), "FIELDS", FALSE))
2721          && isGV(*fields) && GvHV(*fields);
2722 
2723     for (; key_op; key_op = cSVOPx(OpSIBLING(key_op))) {
2724         SV **svp, *sv;
2725         if (key_op->op_type != OP_CONST)
2726             continue;
2727         svp = cSVOPx_svp(key_op);
2728 
2729         /* make sure it's not a bareword under strict subs */
2730         if (key_op->op_private & OPpCONST_BARE &&
2731             key_op->op_private & OPpCONST_STRICT)
2732         {
2733             no_bareword_allowed((OP*)key_op);
2734         }
2735 
2736         /* Make the CONST have a shared SV */
2737         if (   !SvIsCOW_shared_hash(sv = *svp)
2738             && SvTYPE(sv) < SVt_PVMG
2739             && SvOK(sv)
2740             && !SvROK(sv)
2741             && real)
2742         {
2743             SSize_t keylen;
2744             const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2745             SV *nsv = newSVpvn_share(key, SvUTF8(sv) ? -keylen : keylen, 0);
2746             SvREFCNT_dec_NN(sv);
2747             *svp = nsv;
2748         }
2749 
2750         if (   check_fields
2751             && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0))
2752         {
2753             Perl_croak(aTHX_ "No such class field \"%" SVf "\" "
2754                         "in variable %" PNf " of type %" HEKf,
2755                         SVfARG(*svp), PNfARG(lexname),
2756                         HEKfARG(HvNAME_HEK(PadnameTYPE(lexname))));
2757         }
2758     }
2759 }
2760 
2761 
2762 /* do all the final processing on an optree (e.g. running the peephole
2763  * optimiser on it), then attach it to cv (if cv is non-null)
2764  */
2765 
2766 static void
S_process_optree(pTHX_ CV * cv,OP * optree,OP * start)2767 S_process_optree(pTHX_ CV *cv, OP *optree, OP* start)
2768 {
2769     OP **startp;
2770 
2771     /* XXX for some reason, evals, require and main optrees are
2772      * never attached to their CV; instead they just hang off
2773      * PL_main_root + PL_main_start or PL_eval_root + PL_eval_start
2774      * and get manually freed when appropriate */
2775     if (cv)
2776         startp = &CvSTART(cv);
2777     else
2778         startp = PL_in_eval? &PL_eval_start : &PL_main_start;
2779 
2780     *startp = start;
2781     optree->op_private |= OPpREFCOUNTED;
2782     OpREFCNT_set(optree, 1);
2783     optimize_optree(optree);
2784     CALL_PEEP(*startp);
2785     finalize_optree(optree);
2786     op_prune_chain_head(startp);
2787 
2788     if (cv) {
2789         /* now that optimizer has done its work, adjust pad values */
2790         pad_tidy(optree->op_type == OP_LEAVEWRITE ? padtidy_FORMAT
2791                  : CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
2792     }
2793 }
2794 
2795 #ifdef USE_ITHREADS
2796 /* Relocate sv to the pad for thread safety.
2797  * Despite being a "constant", the SV is written to,
2798  * for reference counts, sv_upgrade() etc. */
2799 void
Perl_op_relocate_sv(pTHX_ SV ** svp,PADOFFSET * targp)2800 Perl_op_relocate_sv(pTHX_ SV** svp, PADOFFSET* targp)
2801 {
2802     PADOFFSET ix;
2803     PERL_ARGS_ASSERT_OP_RELOCATE_SV;
2804     if (!*svp) return;
2805     ix = pad_alloc(OP_CONST, SVf_READONLY);
2806     SvREFCNT_dec(PAD_SVl(ix));
2807     PAD_SETSV(ix, *svp);
2808     /* XXX I don't know how this isn't readonly already. */
2809     if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
2810     *svp = NULL;
2811     *targp = ix;
2812 }
2813 #endif
2814 
2815 static void
S_mark_padname_lvalue(pTHX_ PADNAME * pn)2816 S_mark_padname_lvalue(pTHX_ PADNAME *pn)
2817 {
2818     CV *cv = PL_compcv;
2819     PadnameLVALUE_on(pn);
2820     while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
2821         cv = CvOUTSIDE(cv);
2822         /* RT #127786: cv can be NULL due to an eval within the DB package
2823          * called from an anon sub - anon subs don't have CvOUTSIDE() set
2824          * unless they contain an eval, but calling eval within DB
2825          * pretends the eval was done in the caller's scope.
2826          */
2827         if (!cv)
2828             break;
2829         assert(CvPADLIST(cv));
2830         pn =
2831            PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
2832         assert(PadnameLEN(pn));
2833         PadnameLVALUE_on(pn);
2834     }
2835 }
2836 
2837 static bool
S_vivifies(const OPCODE type)2838 S_vivifies(const OPCODE type)
2839 {
2840     switch(type) {
2841     case OP_RV2AV:     case   OP_ASLICE:
2842     case OP_RV2HV:     case OP_KVASLICE:
2843     case OP_RV2SV:     case   OP_HSLICE:
2844     case OP_AELEMFAST: case OP_KVHSLICE:
2845     case OP_HELEM:
2846     case OP_AELEM:
2847         return 1;
2848     }
2849     return 0;
2850 }
2851 
2852 
2853 /* apply lvalue reference (aliasing) context to the optree o.
2854  * E.g. in
2855  *     \($x,$y) = (...)
2856  * o would be the list ($x,$y) and type would be OP_AASSIGN.
2857  * It may descend and apply this to children too, for example in
2858  * \( $cond ? $x, $y) = (...)
2859  */
2860 
2861 static void
S_lvref(pTHX_ OP * o,I32 type)2862 S_lvref(pTHX_ OP *o, I32 type)
2863 {
2864     OP *kid;
2865     OP * top_op = o;
2866 
2867     while (1) {
2868         switch (o->op_type) {
2869         case OP_COND_EXPR:
2870             o = OpSIBLING(cUNOPo->op_first);
2871             continue;
2872 
2873         case OP_PUSHMARK:
2874             goto do_next;
2875 
2876         case OP_RV2AV:
2877             if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2878             o->op_flags |= OPf_STACKED;
2879             if (o->op_flags & OPf_PARENS) {
2880                 if (o->op_private & OPpLVAL_INTRO) {
2881                      yyerror(Perl_form(aTHX_ "Can't modify reference to "
2882                           "localized parenthesized array in list assignment"));
2883                     goto do_next;
2884                 }
2885               slurpy:
2886                 OpTYPE_set(o, OP_LVAVREF);
2887                 o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
2888                 o->op_flags |= OPf_MOD|OPf_REF;
2889                 goto do_next;
2890             }
2891             o->op_private |= OPpLVREF_AV;
2892             goto checkgv;
2893 
2894         case OP_RV2CV:
2895             kid = cUNOPo->op_first;
2896             if (kid->op_type == OP_NULL)
2897                 kid = cUNOPx(OpSIBLING(kUNOP->op_first))
2898                     ->op_first;
2899             o->op_private = OPpLVREF_CV;
2900             if (kid->op_type == OP_GV)
2901                 o->op_flags |= OPf_STACKED;
2902             else if (kid->op_type == OP_PADCV) {
2903                 o->op_targ = kid->op_targ;
2904                 kid->op_targ = 0;
2905                 op_free(cUNOPo->op_first);
2906                 cUNOPo->op_first = NULL;
2907                 o->op_flags &=~ OPf_KIDS;
2908             }
2909             else goto badref;
2910             break;
2911 
2912         case OP_RV2HV:
2913             if (o->op_flags & OPf_PARENS) {
2914               parenhash:
2915                 yyerror(Perl_form(aTHX_ "Can't modify reference to "
2916                                      "parenthesized hash in list assignment"));
2917                     goto do_next;
2918             }
2919             o->op_private |= OPpLVREF_HV;
2920             /* FALLTHROUGH */
2921         case OP_RV2SV:
2922           checkgv:
2923             if (cUNOPo->op_first->op_type != OP_GV) goto badref;
2924             o->op_flags |= OPf_STACKED;
2925             break;
2926 
2927         case OP_PADHV:
2928             if (o->op_flags & OPf_PARENS) goto parenhash;
2929             o->op_private |= OPpLVREF_HV;
2930             /* FALLTHROUGH */
2931         case OP_PADSV:
2932             PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2933             break;
2934 
2935         case OP_PADAV:
2936             PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
2937             if (o->op_flags & OPf_PARENS) goto slurpy;
2938             o->op_private |= OPpLVREF_AV;
2939             break;
2940 
2941         case OP_AELEM:
2942         case OP_HELEM:
2943             o->op_private |= OPpLVREF_ELEM;
2944             o->op_flags   |= OPf_STACKED;
2945             break;
2946 
2947         case OP_ASLICE:
2948         case OP_HSLICE:
2949             OpTYPE_set(o, OP_LVREFSLICE);
2950             o->op_private &= OPpLVAL_INTRO;
2951             goto do_next;
2952 
2953         case OP_NULL:
2954             if (o->op_flags & OPf_SPECIAL)		/* do BLOCK */
2955                 goto badref;
2956             else if (!(o->op_flags & OPf_KIDS))
2957                 goto do_next;
2958 
2959             /* the code formerly only recursed into the first child of
2960              * a non ex-list OP_NULL. if we ever encounter such a null op with
2961              * more than one child, need to decide whether its ok to process
2962              * *all* its kids or not */
2963             assert(o->op_targ == OP_LIST
2964                     || !(OpHAS_SIBLING(cBINOPo->op_first)));
2965             /* FALLTHROUGH */
2966         case OP_LIST:
2967             o = cLISTOPo->op_first;
2968             continue;
2969 
2970         case OP_STUB:
2971             if (o->op_flags & OPf_PARENS)
2972                 goto do_next;
2973             /* FALLTHROUGH */
2974         default:
2975           badref:
2976             /* diag_listed_as: Can't modify reference to %s in %s assignment */
2977             yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
2978                          o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
2979                           ? "do block"
2980                           : OP_DESC(o),
2981                          PL_op_desc[type]));
2982             goto do_next;
2983         }
2984 
2985         OpTYPE_set(o, OP_LVREF);
2986         o->op_private &=
2987             OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
2988         if (type == OP_ENTERLOOP)
2989             o->op_private |= OPpLVREF_ITER;
2990 
2991       do_next:
2992         while (1) {
2993             if (o == top_op)
2994                 return; /* at top; no parents/siblings to try */
2995             if (OpHAS_SIBLING(o)) {
2996                 o = o->op_sibparent;
2997                 break;
2998             }
2999             o = o->op_sibparent; /*try parent's next sibling */
3000         }
3001     } /* while */
3002 }
3003 
3004 
3005 PERL_STATIC_INLINE bool
S_potential_mod_type(I32 type)3006 S_potential_mod_type(I32 type)
3007 {
3008     /* Types that only potentially result in modification.  */
3009     return type == OP_GREPSTART || type == OP_ENTERSUB
3010         || type == OP_REFGEN    || type == OP_LEAVESUBLV;
3011 }
3012 
3013 
3014 /*
3015 =for apidoc op_lvalue
3016 
3017 Propagate lvalue ("modifiable") context to an op and its children.
3018 C<type> represents the context type, roughly based on the type of op that
3019 would do the modifying, although C<local()> is represented by C<OP_NULL>,
3020 because it has no op type of its own (it is signalled by a flag on
3021 the lvalue op).
3022 
3023 This function detects things that can't be modified, such as C<$x+1>, and
3024 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
3025 called with an op of type C<OP_ADD> and a C<type> argument of C<OP_SASSIGN>.
3026 
3027 It also flags things that need to behave specially in an lvalue context,
3028 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3029 
3030 =cut
3031 
3032 Perl_op_lvalue_flags() is a non-API lower-level interface to
3033 op_lvalue().  The flags param has these bits:
3034     OP_LVALUE_NO_CROAK:  return rather than croaking on error
3035 
3036 */
3037 
3038 OP *
Perl_op_lvalue_flags(pTHX_ OP * o,I32 type,U32 flags)3039 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
3040 {
3041     OP *top_op = o;
3042 
3043     if (!o || (PL_parser && PL_parser->error_count))
3044         return o;
3045 
3046     while (1) {
3047     OP *kid;
3048     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
3049     int localize = -1;
3050     OP *next_kid = NULL;
3051 
3052     if ((o->op_private & OPpTARGET_MY)
3053         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
3054     {
3055         goto do_next;
3056     }
3057 
3058     /* elements of a list might be in void context because the list is
3059        in scalar context or because they are attribute sub calls */
3060     if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
3061         goto do_next;
3062 
3063     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
3064 
3065     switch (o->op_type) {
3066     case OP_UNDEF:
3067         if (type == OP_SASSIGN)
3068             goto nomod;
3069         PL_modcount++;
3070         goto do_next;
3071 
3072     case OP_STUB:
3073         if ((o->op_flags & OPf_PARENS))
3074             break;
3075         goto nomod;
3076 
3077     case OP_ENTERSUB:
3078         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
3079             !(o->op_flags & OPf_STACKED)) {
3080             OpTYPE_set(o, OP_RV2CV);		/* entersub => rv2cv */
3081             assert(cUNOPo->op_first->op_type == OP_NULL);
3082             op_null(cLISTOPx(cUNOPo->op_first)->op_first);/* disable pushmark */
3083             break;
3084         }
3085         else {				/* lvalue subroutine call */
3086             o->op_private |= OPpLVAL_INTRO;
3087             PL_modcount = RETURN_UNLIMITED_NUMBER;
3088             if (S_potential_mod_type(type)) {
3089                 o->op_private |= OPpENTERSUB_INARGS;
3090                 break;
3091             }
3092             else {                      /* Compile-time error message: */
3093                 OP *kid = cUNOPo->op_first;
3094                 CV *cv;
3095                 GV *gv;
3096                 SV *namesv;
3097 
3098                 if (kid->op_type != OP_PUSHMARK) {
3099                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
3100                         Perl_croak(aTHX_
3101                                 "panic: unexpected lvalue entersub "
3102                                 "args: type/targ %ld:%" UVuf,
3103                                 (long)kid->op_type, (UV)kid->op_targ);
3104                     kid = kLISTOP->op_first;
3105                 }
3106                 while (OpHAS_SIBLING(kid))
3107                     kid = OpSIBLING(kid);
3108                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
3109                     break;	/* Postpone until runtime */
3110                 }
3111 
3112                 kid = kUNOP->op_first;
3113                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
3114                     kid = kUNOP->op_first;
3115                 if (kid->op_type == OP_NULL)
3116                     Perl_croak(aTHX_
3117                                "panic: unexpected constant lvalue entersub "
3118                                "entry via type/targ %ld:%" UVuf,
3119                                (long)kid->op_type, (UV)kid->op_targ);
3120                 if (kid->op_type != OP_GV) {
3121                     break;
3122                 }
3123 
3124                 gv = kGVOP_gv;
3125                 cv = isGV(gv)
3126                     ? GvCV(gv)
3127                     : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
3128                         ? MUTABLE_CV(SvRV(gv))
3129                         : NULL;
3130                 if (!cv)
3131                     break;
3132                 if (CvLVALUE(cv))
3133                     break;
3134                 if (flags & OP_LVALUE_NO_CROAK)
3135                     return NULL;
3136 
3137                 namesv = cv_name(cv, NULL, 0);
3138                 yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
3139                                      "subroutine call of &%" SVf " in %s",
3140                                      SVfARG(namesv), PL_op_desc[type]),
3141                            SvUTF8(namesv));
3142                 goto do_next;
3143             }
3144         }
3145         /* FALLTHROUGH */
3146     default:
3147       nomod:
3148         if (flags & OP_LVALUE_NO_CROAK) return NULL;
3149         /* grep, foreach, subcalls, refgen */
3150         if (S_potential_mod_type(type))
3151             break;
3152         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
3153                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
3154                       ? "do block"
3155                       : OP_DESC(o)),
3156                      type ? PL_op_desc[type] : "local"));
3157         goto do_next;
3158 
3159     case OP_PREINC:
3160     case OP_PREDEC:
3161     case OP_POW:
3162     case OP_MULTIPLY:
3163     case OP_DIVIDE:
3164     case OP_MODULO:
3165     case OP_ADD:
3166     case OP_SUBTRACT:
3167     case OP_CONCAT:
3168     case OP_LEFT_SHIFT:
3169     case OP_RIGHT_SHIFT:
3170     case OP_BIT_AND:
3171     case OP_BIT_XOR:
3172     case OP_BIT_OR:
3173     case OP_I_MULTIPLY:
3174     case OP_I_DIVIDE:
3175     case OP_I_MODULO:
3176     case OP_I_ADD:
3177     case OP_I_SUBTRACT:
3178         if (!(o->op_flags & OPf_STACKED))
3179             goto nomod;
3180         PL_modcount++;
3181         break;
3182 
3183     case OP_REPEAT:
3184         if (o->op_flags & OPf_STACKED) {
3185             PL_modcount++;
3186             break;
3187         }
3188         if (!(o->op_private & OPpREPEAT_DOLIST))
3189             goto nomod;
3190         else {
3191             const I32 mods = PL_modcount;
3192             /* we recurse rather than iterate here because we need to
3193              * calculate and use the delta applied to PL_modcount by the
3194              * first child. So in something like
3195              *     ($x, ($y) x 3) = split;
3196              * split knows that 4 elements are wanted
3197              */
3198             modkids(cBINOPo->op_first, type);
3199             if (type != OP_AASSIGN)
3200                 goto nomod;
3201             kid = cBINOPo->op_last;
3202             if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
3203                 const IV iv = SvIV(kSVOP_sv);
3204                 if (PL_modcount != RETURN_UNLIMITED_NUMBER)
3205                     PL_modcount =
3206                         mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
3207             }
3208             else
3209                 PL_modcount = RETURN_UNLIMITED_NUMBER;
3210         }
3211         break;
3212 
3213     case OP_COND_EXPR:
3214         localize = 1;
3215         next_kid = OpSIBLING(cUNOPo->op_first);
3216         break;
3217 
3218     case OP_RV2AV:
3219     case OP_RV2HV:
3220         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
3221            PL_modcount = RETURN_UNLIMITED_NUMBER;
3222            /* Treat \(@foo) like ordinary list, but still mark it as modi-
3223               fiable since some contexts need to know.  */
3224            o->op_flags |= OPf_MOD;
3225            goto do_next;
3226         }
3227         /* FALLTHROUGH */
3228     case OP_RV2GV:
3229         if (scalar_mod_type(o, type))
3230             goto nomod;
3231         ref(cUNOPo->op_first, o->op_type);
3232         /* FALLTHROUGH */
3233     case OP_ASLICE:
3234     case OP_HSLICE:
3235         localize = 1;
3236         /* FALLTHROUGH */
3237     case OP_AASSIGN:
3238         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
3239         if (type == OP_LEAVESUBLV && (
3240                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
3241              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3242            ))
3243             o->op_private |= OPpMAYBE_LVSUB;
3244         /* FALLTHROUGH */
3245     case OP_NEXTSTATE:
3246     case OP_DBSTATE:
3247        PL_modcount = RETURN_UNLIMITED_NUMBER;
3248         break;
3249 
3250     case OP_KVHSLICE:
3251     case OP_KVASLICE:
3252     case OP_AKEYS:
3253         if (type == OP_LEAVESUBLV)
3254             o->op_private |= OPpMAYBE_LVSUB;
3255         goto nomod;
3256 
3257     case OP_AVHVSWITCH:
3258         if (type == OP_LEAVESUBLV
3259          && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
3260             o->op_private |= OPpMAYBE_LVSUB;
3261         goto nomod;
3262 
3263     case OP_AV2ARYLEN:
3264         PL_hints |= HINT_BLOCK_SCOPE;
3265         if (type == OP_LEAVESUBLV)
3266             o->op_private |= OPpMAYBE_LVSUB;
3267         PL_modcount++;
3268         break;
3269 
3270     case OP_RV2SV:
3271         ref(cUNOPo->op_first, o->op_type);
3272         localize = 1;
3273         /* FALLTHROUGH */
3274     case OP_GV:
3275         PL_hints |= HINT_BLOCK_SCOPE;
3276         /* FALLTHROUGH */
3277     case OP_SASSIGN:
3278     case OP_ANDASSIGN:
3279     case OP_ORASSIGN:
3280     case OP_DORASSIGN:
3281         PL_modcount++;
3282         break;
3283 
3284     case OP_AELEMFAST:
3285     case OP_AELEMFAST_LEX:
3286         localize = -1;
3287         PL_modcount++;
3288         break;
3289 
3290     case OP_PADAV:
3291     case OP_PADHV:
3292        PL_modcount = RETURN_UNLIMITED_NUMBER;
3293         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
3294         {
3295            /* Treat \(@foo) like ordinary list, but still mark it as modi-
3296               fiable since some contexts need to know.  */
3297             o->op_flags |= OPf_MOD;
3298             goto do_next;
3299         }
3300         if (scalar_mod_type(o, type))
3301             goto nomod;
3302         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
3303           && type == OP_LEAVESUBLV)
3304             o->op_private |= OPpMAYBE_LVSUB;
3305         /* FALLTHROUGH */
3306     case OP_PADSV:
3307         PL_modcount++;
3308         if (!type) /* local() */
3309             Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
3310                               PNfARG(PAD_COMPNAME(o->op_targ)));
3311         if (!(o->op_private & OPpLVAL_INTRO)
3312          || (  type != OP_SASSIGN && type != OP_AASSIGN
3313             && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ))  ))
3314             S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
3315         break;
3316 
3317     case OP_PUSHMARK:
3318         localize = 0;
3319         break;
3320 
3321     case OP_KEYS:
3322         if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
3323             goto nomod;
3324         goto lvalue_func;
3325     case OP_SUBSTR:
3326         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
3327             goto nomod;
3328         /* FALLTHROUGH */
3329     case OP_POS:
3330     case OP_VEC:
3331       lvalue_func:
3332         if (type == OP_LEAVESUBLV)
3333             o->op_private |= OPpMAYBE_LVSUB;
3334         if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
3335             /* we recurse rather than iterate here because the child
3336              * needs to be processed with a different 'type' parameter */
3337 
3338             /* substr and vec */
3339             /* If this op is in merely potential (non-fatal) modifiable
3340                context, then apply OP_ENTERSUB context to
3341                the kid op (to avoid croaking).  Other-
3342                wise pass this op’s own type so the correct op is mentioned
3343                in error messages.  */
3344             op_lvalue(OpSIBLING(cBINOPo->op_first),
3345                       S_potential_mod_type(type)
3346                         ? (I32)OP_ENTERSUB
3347                         : o->op_type);
3348         }
3349         break;
3350 
3351     case OP_AELEM:
3352     case OP_HELEM:
3353         ref(cBINOPo->op_first, o->op_type);
3354         if (type == OP_ENTERSUB &&
3355              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
3356             o->op_private |= OPpLVAL_DEFER;
3357         if (type == OP_LEAVESUBLV)
3358             o->op_private |= OPpMAYBE_LVSUB;
3359         localize = 1;
3360         PL_modcount++;
3361         break;
3362 
3363     case OP_LEAVE:
3364     case OP_LEAVELOOP:
3365         o->op_private |= OPpLVALUE;
3366         /* FALLTHROUGH */
3367     case OP_SCOPE:
3368     case OP_ENTER:
3369     case OP_LINESEQ:
3370         localize = 0;
3371         if (o->op_flags & OPf_KIDS)
3372             next_kid = cLISTOPo->op_last;
3373         break;
3374 
3375     case OP_NULL:
3376         localize = 0;
3377         if (o->op_flags & OPf_SPECIAL)		/* do BLOCK */
3378             goto nomod;
3379         else if (!(o->op_flags & OPf_KIDS))
3380             break;
3381 
3382         if (o->op_targ != OP_LIST) {
3383             OP *sib = OpSIBLING(cLISTOPo->op_first);
3384             /* OP_TRANS and OP_TRANSR with argument have a weird optree
3385              * that looks like
3386              *
3387              *   null
3388              *      arg
3389              *      trans
3390              *
3391              * compared with things like OP_MATCH which have the argument
3392              * as a child:
3393              *
3394              *   match
3395              *      arg
3396              *
3397              * so handle specially to correctly get "Can't modify" croaks etc
3398              */
3399 
3400             if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
3401             {
3402                 /* this should trigger a "Can't modify transliteration" err */
3403                 op_lvalue(sib, type);
3404             }
3405             next_kid = cBINOPo->op_first;
3406             /* we assume OP_NULLs which aren't ex-list have no more than 2
3407              * children. If this assumption is wrong, increase the scan
3408              * limit below */
3409             assert(   !OpHAS_SIBLING(next_kid)
3410                    || !OpHAS_SIBLING(OpSIBLING(next_kid)));
3411             break;
3412         }
3413         /* FALLTHROUGH */
3414     case OP_LIST:
3415         localize = 0;
3416         next_kid = cLISTOPo->op_first;
3417         break;
3418 
3419     case OP_COREARGS:
3420         goto do_next;
3421 
3422     case OP_AND:
3423     case OP_OR:
3424         if (type == OP_LEAVESUBLV
3425          || !S_vivifies(cLOGOPo->op_first->op_type))
3426             next_kid = cLOGOPo->op_first;
3427         else if (type == OP_LEAVESUBLV
3428          || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
3429             next_kid = OpSIBLING(cLOGOPo->op_first);
3430         goto nomod;
3431 
3432     case OP_SREFGEN:
3433         if (type == OP_NULL) { /* local */
3434           local_refgen:
3435             if (!FEATURE_MYREF_IS_ENABLED)
3436                 Perl_croak(aTHX_ "The experimental declared_refs "
3437                                  "feature is not enabled");
3438             Perl_ck_warner_d(aTHX_
3439                      packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
3440                     "Declaring references is experimental");
3441             next_kid = cUNOPo->op_first;
3442             goto do_next;
3443         }
3444         if (type != OP_AASSIGN && type != OP_SASSIGN
3445          && type != OP_ENTERLOOP)
3446             goto nomod;
3447         /* Don’t bother applying lvalue context to the ex-list.  */
3448         kid = cUNOPx(cUNOPo->op_first)->op_first;
3449         assert (!OpHAS_SIBLING(kid));
3450         goto kid_2lvref;
3451     case OP_REFGEN:
3452         if (type == OP_NULL) /* local */
3453             goto local_refgen;
3454         if (type != OP_AASSIGN) goto nomod;
3455         kid = cUNOPo->op_first;
3456       kid_2lvref:
3457         {
3458             const U8 ec = PL_parser ? PL_parser->error_count : 0;
3459             S_lvref(aTHX_ kid, type);
3460             if (!PL_parser || PL_parser->error_count == ec) {
3461                 if (!FEATURE_REFALIASING_IS_ENABLED)
3462                     Perl_croak(aTHX_
3463                        "Experimental aliasing via reference not enabled");
3464                 Perl_ck_warner_d(aTHX_
3465                                  packWARN(WARN_EXPERIMENTAL__REFALIASING),
3466                                 "Aliasing via reference is experimental");
3467             }
3468         }
3469         if (o->op_type == OP_REFGEN)
3470             op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
3471         op_null(o);
3472         goto do_next;
3473 
3474     case OP_SPLIT:
3475         if ((o->op_private & OPpSPLIT_ASSIGN)) {
3476             /* This is actually @array = split.  */
3477             PL_modcount = RETURN_UNLIMITED_NUMBER;
3478             break;
3479         }
3480         goto nomod;
3481 
3482     case OP_SCALAR:
3483         op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
3484         goto nomod;
3485 
3486     case OP_ANONCODE:
3487         /* If we were to set OPf_REF on this and it was constructed by XS
3488          * code as a child of an OP_REFGEN then we'd end up generating a
3489          * double-ref when executed. We don't want to do that, so don't
3490          * set flag here.
3491          *   See also https://github.com/Perl/perl5/issues/20384
3492          */
3493 
3494         // Perl always sets OPf_REF as of 5.37.5.
3495         //
3496         if (LIKELY(o->op_flags & OPf_REF)) goto nomod;
3497 
3498         // If we got here, then our op came from an XS module that predates
3499         // 5.37.5’s change to the op tree, which we have to handle a bit
3500         // diffrently to preserve backward compatibility.
3501         //
3502         goto do_next;
3503     }
3504 
3505     /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
3506        their argument is a filehandle; thus \stat(".") should not set
3507        it. AMS 20011102 */
3508     if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
3509         goto do_next;
3510 
3511     if (type != OP_LEAVESUBLV)
3512         o->op_flags |= OPf_MOD;
3513 
3514     if (type == OP_AASSIGN || type == OP_SASSIGN)
3515         o->op_flags |= o->op_type == OP_ENTERSUB ? 0 : OPf_SPECIAL|OPf_REF;
3516     else if (!type) { /* local() */
3517         switch (localize) {
3518         case 1:
3519             o->op_private |= OPpLVAL_INTRO;
3520             o->op_flags &= ~OPf_SPECIAL;
3521             PL_hints |= HINT_BLOCK_SCOPE;
3522             break;
3523         case 0:
3524             break;
3525         case -1:
3526             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
3527                            "Useless localization of %s", OP_DESC(o));
3528         }
3529     }
3530     else if (type != OP_GREPSTART && type != OP_ENTERSUB
3531              && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
3532         o->op_flags |= OPf_REF;
3533 
3534   do_next:
3535     while (!next_kid) {
3536         if (o == top_op)
3537             return top_op; /* at top; no parents/siblings to try */
3538         if (OpHAS_SIBLING(o)) {
3539             next_kid = o->op_sibparent;
3540             if (!OpHAS_SIBLING(next_kid)) {
3541                 /* a few node types don't recurse into their second child */
3542                 OP *parent = next_kid->op_sibparent;
3543                 I32 ptype  = parent->op_type;
3544                 if (   (ptype == OP_NULL && parent->op_targ != OP_LIST)
3545                     || (   (ptype == OP_AND || ptype == OP_OR)
3546                         && (type != OP_LEAVESUBLV
3547                             && S_vivifies(next_kid->op_type))
3548                        )
3549                 )  {
3550                     /*try parent's next sibling */
3551                     o = parent;
3552                     next_kid =  NULL;
3553                 }
3554             }
3555         }
3556         else
3557             o = o->op_sibparent; /*try parent's next sibling */
3558 
3559     }
3560     o = next_kid;
3561 
3562     } /* while */
3563 
3564 }
3565 
3566 
3567 STATIC bool
S_scalar_mod_type(const OP * o,I32 type)3568 S_scalar_mod_type(const OP *o, I32 type)
3569 {
3570     switch (type) {
3571     case OP_POS:
3572     case OP_SASSIGN:
3573         if (o && o->op_type == OP_RV2GV)
3574             return FALSE;
3575         /* FALLTHROUGH */
3576     case OP_PREINC:
3577     case OP_PREDEC:
3578     case OP_POSTINC:
3579     case OP_POSTDEC:
3580     case OP_I_PREINC:
3581     case OP_I_PREDEC:
3582     case OP_I_POSTINC:
3583     case OP_I_POSTDEC:
3584     case OP_POW:
3585     case OP_MULTIPLY:
3586     case OP_DIVIDE:
3587     case OP_MODULO:
3588     case OP_REPEAT:
3589     case OP_ADD:
3590     case OP_SUBTRACT:
3591     case OP_I_MULTIPLY:
3592     case OP_I_DIVIDE:
3593     case OP_I_MODULO:
3594     case OP_I_ADD:
3595     case OP_I_SUBTRACT:
3596     case OP_LEFT_SHIFT:
3597     case OP_RIGHT_SHIFT:
3598     case OP_BIT_AND:
3599     case OP_BIT_XOR:
3600     case OP_BIT_OR:
3601     case OP_NBIT_AND:
3602     case OP_NBIT_XOR:
3603     case OP_NBIT_OR:
3604     case OP_SBIT_AND:
3605     case OP_SBIT_XOR:
3606     case OP_SBIT_OR:
3607     case OP_CONCAT:
3608     case OP_SUBST:
3609     case OP_TRANS:
3610     case OP_TRANSR:
3611     case OP_READ:
3612     case OP_SYSREAD:
3613     case OP_RECV:
3614     case OP_ANDASSIGN:
3615     case OP_ORASSIGN:
3616     case OP_DORASSIGN:
3617     case OP_VEC:
3618     case OP_SUBSTR:
3619         return TRUE;
3620     default:
3621         return FALSE;
3622     }
3623 }
3624 
3625 STATIC bool
S_is_handle_constructor(const OP * o,I32 numargs)3626 S_is_handle_constructor(const OP *o, I32 numargs)
3627 {
3628     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
3629 
3630     switch (o->op_type) {
3631     case OP_PIPE_OP:
3632     case OP_SOCKPAIR:
3633         if (numargs == 2)
3634             return TRUE;
3635         /* FALLTHROUGH */
3636     case OP_SYSOPEN:
3637     case OP_OPEN:
3638     case OP_SELECT:		/* XXX c.f. SelectSaver.pm */
3639     case OP_SOCKET:
3640     case OP_OPEN_DIR:
3641     case OP_ACCEPT:
3642         if (numargs == 1)
3643             return TRUE;
3644         /* FALLTHROUGH */
3645     default:
3646         return FALSE;
3647     }
3648 }
3649 
3650 static OP *
S_refkids(pTHX_ OP * o,I32 type)3651 S_refkids(pTHX_ OP *o, I32 type)
3652 {
3653     if (o && o->op_flags & OPf_KIDS) {
3654         OP *kid;
3655         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
3656             ref(kid, type);
3657     }
3658     return o;
3659 }
3660 
3661 
3662 /* Apply reference (autovivification) context to the subtree at o.
3663  * For example in
3664  *     push @{expression}, ....;
3665  * o will be the head of 'expression' and type will be OP_RV2AV.
3666  * It marks the op o (or a suitable child) as autovivifying, e.g. by
3667  * setting  OPf_MOD.
3668  * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
3669  * set_op_ref is true.
3670  *
3671  * Also calls scalar(o).
3672  */
3673 
3674 OP *
Perl_doref(pTHX_ OP * o,I32 type,bool set_op_ref)3675 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
3676 {
3677     OP * top_op = o;
3678 
3679     PERL_ARGS_ASSERT_DOREF;
3680 
3681     if (PL_parser && PL_parser->error_count)
3682         return o;
3683 
3684     while (1) {
3685         switch (o->op_type) {
3686         case OP_ENTERSUB:
3687             if ((type == OP_EXISTS || type == OP_DEFINED) &&
3688                 !(o->op_flags & OPf_STACKED)) {
3689                 OpTYPE_set(o, OP_RV2CV);             /* entersub => rv2cv */
3690                 assert(cUNOPo->op_first->op_type == OP_NULL);
3691                 /* disable pushmark */
3692                 op_null(cLISTOPx(cUNOPo->op_first)->op_first);
3693                 o->op_flags |= OPf_SPECIAL;
3694             }
3695             else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
3696                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3697                                   : type == OP_RV2HV ? OPpDEREF_HV
3698                                   : OPpDEREF_SV);
3699                 o->op_flags |= OPf_MOD;
3700             }
3701 
3702             break;
3703 
3704         case OP_COND_EXPR:
3705             o = OpSIBLING(cUNOPo->op_first);
3706             continue;
3707 
3708         case OP_RV2SV:
3709             if (type == OP_DEFINED)
3710                 o->op_flags |= OPf_SPECIAL;		/* don't create GV */
3711             /* FALLTHROUGH */
3712         case OP_PADSV:
3713             if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3714                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3715                                   : type == OP_RV2HV ? OPpDEREF_HV
3716                                   : OPpDEREF_SV);
3717                 o->op_flags |= OPf_MOD;
3718             }
3719             if (o->op_flags & OPf_KIDS) {
3720                 type = o->op_type;
3721                 o = cUNOPo->op_first;
3722                 continue;
3723             }
3724             break;
3725 
3726         case OP_RV2AV:
3727         case OP_RV2HV:
3728             if (set_op_ref)
3729                 o->op_flags |= OPf_REF;
3730             /* FALLTHROUGH */
3731         case OP_RV2GV:
3732             if (type == OP_DEFINED)
3733                 o->op_flags |= OPf_SPECIAL;		/* don't create GV */
3734             type = o->op_type;
3735             o = cUNOPo->op_first;
3736             continue;
3737 
3738         case OP_PADAV:
3739         case OP_PADHV:
3740             if (set_op_ref)
3741                 o->op_flags |= OPf_REF;
3742             break;
3743 
3744         case OP_SCALAR:
3745         case OP_NULL:
3746             if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
3747                 break;
3748              o = cBINOPo->op_first;
3749             continue;
3750 
3751         case OP_AELEM:
3752         case OP_HELEM:
3753             if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
3754                 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
3755                                   : type == OP_RV2HV ? OPpDEREF_HV
3756                                   : OPpDEREF_SV);
3757                 o->op_flags |= OPf_MOD;
3758             }
3759             type = o->op_type;
3760             o = cBINOPo->op_first;
3761             continue;;
3762 
3763         case OP_SCOPE:
3764         case OP_LEAVE:
3765             set_op_ref = FALSE;
3766             /* FALLTHROUGH */
3767         case OP_ENTER:
3768         case OP_LIST:
3769             if (!(o->op_flags & OPf_KIDS))
3770                 break;
3771             o = cLISTOPo->op_last;
3772             continue;
3773 
3774         default:
3775             break;
3776         } /* switch */
3777 
3778         while (1) {
3779             if (o == top_op)
3780                 return scalar(top_op); /* at top; no parents/siblings to try */
3781             if (OpHAS_SIBLING(o)) {
3782                 o = o->op_sibparent;
3783                 /* Normally skip all siblings and go straight to the parent;
3784                  * the only op that requires two children to be processed
3785                  * is OP_COND_EXPR */
3786                 if (!OpHAS_SIBLING(o)
3787                         && o->op_sibparent->op_type == OP_COND_EXPR)
3788                     break;
3789                 continue;
3790             }
3791             o = o->op_sibparent; /*try parent's next sibling */
3792         }
3793     } /* while */
3794 }
3795 
3796 
3797 STATIC OP *
S_dup_attrlist(pTHX_ OP * o)3798 S_dup_attrlist(pTHX_ OP *o)
3799 {
3800     OP *rop;
3801 
3802     PERL_ARGS_ASSERT_DUP_ATTRLIST;
3803 
3804     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
3805      * where the first kid is OP_PUSHMARK and the remaining ones
3806      * are OP_CONST.  We need to push the OP_CONST values.
3807      */
3808     if (o->op_type == OP_CONST)
3809         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
3810     else {
3811         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
3812         rop = NULL;
3813         for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
3814             if (o->op_type == OP_CONST)
3815                 rop = op_append_elem(OP_LIST, rop,
3816                                   newSVOP(OP_CONST, o->op_flags,
3817                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
3818         }
3819     }
3820     return rop;
3821 }
3822 
3823 STATIC void
S_apply_attrs(pTHX_ HV * stash,SV * target,OP * attrs)3824 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
3825 {
3826     PERL_ARGS_ASSERT_APPLY_ATTRS;
3827     {
3828         SV * const stashsv = newSVhek(HvNAME_HEK(stash));
3829 
3830         /* fake up C<use attributes $pkg,$rv,@attrs> */
3831 
3832 #define ATTRSMODULE "attributes"
3833 #define ATTRSMODULE_PM "attributes.pm"
3834 
3835         Perl_load_module(
3836           aTHX_ PERL_LOADMOD_IMPORT_OPS,
3837           newSVpvs(ATTRSMODULE),
3838           NULL,
3839           op_prepend_elem(OP_LIST,
3840                           newSVOP(OP_CONST, 0, stashsv),
3841                           op_prepend_elem(OP_LIST,
3842                                           newSVOP(OP_CONST, 0,
3843                                                   newRV(target)),
3844                                           dup_attrlist(attrs))));
3845     }
3846 }
3847 
3848 STATIC void
S_apply_attrs_my(pTHX_ HV * stash,OP * target,OP * attrs,OP ** imopsp)3849 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
3850 {
3851     OP *pack, *imop, *arg;
3852     SV *meth, *stashsv, **svp;
3853 
3854     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
3855 
3856     if (!attrs)
3857         return;
3858 
3859     assert(target->op_type == OP_PADSV ||
3860            target->op_type == OP_PADHV ||
3861            target->op_type == OP_PADAV);
3862 
3863     /* Ensure that attributes.pm is loaded. */
3864     /* Don't force the C<use> if we don't need it. */
3865     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
3866     if (svp && *svp != &PL_sv_undef)
3867         NOOP;	/* already in %INC */
3868     else
3869         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
3870                                newSVpvs(ATTRSMODULE), NULL);
3871 
3872     /* Need package name for method call. */
3873     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
3874 
3875     /* Build up the real arg-list. */
3876     stashsv = newSVhek(HvNAME_HEK(stash));
3877 
3878     arg = newPADxVOP(OP_PADSV, 0, target->op_targ);
3879     arg = op_prepend_elem(OP_LIST,
3880                        newSVOP(OP_CONST, 0, stashsv),
3881                        op_prepend_elem(OP_LIST,
3882                                     newUNOP(OP_REFGEN, 0,
3883                                             arg),
3884                                     dup_attrlist(attrs)));
3885 
3886     /* Fake up a method call to import */
3887     meth = newSVpvs_share("import");
3888     imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_WANT_VOID,
3889                    op_append_elem(OP_LIST,
3890                                op_prepend_elem(OP_LIST, pack, arg),
3891                                newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
3892 
3893     /* Combine the ops. */
3894     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
3895 }
3896 
3897 /*
3898 =notfor apidoc apply_attrs_string
3899 
3900 Attempts to apply a list of attributes specified by the C<attrstr> and
3901 C<len> arguments to the subroutine identified by the C<cv> argument which
3902 is expected to be associated with the package identified by the C<stashpv>
3903 argument (see L<attributes>).  It gets this wrong, though, in that it
3904 does not correctly identify the boundaries of the individual attribute
3905 specifications within C<attrstr>.  This is not really intended for the
3906 public API, but has to be listed here for systems such as AIX which
3907 need an explicit export list for symbols.  (It's called from XS code
3908 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
3909 to respect attribute syntax properly would be welcome.
3910 
3911 =cut
3912 */
3913 
3914 void
Perl_apply_attrs_string(pTHX_ const char * stashpv,CV * cv,const char * attrstr,STRLEN len)3915 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
3916                         const char *attrstr, STRLEN len)
3917 {
3918     OP *attrs = NULL;
3919 
3920     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
3921 
3922     if (!len) {
3923         len = strlen(attrstr);
3924     }
3925 
3926     while (len) {
3927         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
3928         if (len) {
3929             const char * const sstr = attrstr;
3930             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
3931             attrs = op_append_elem(OP_LIST, attrs,
3932                                 newSVOP(OP_CONST, 0,
3933                                         newSVpvn(sstr, attrstr-sstr)));
3934         }
3935     }
3936 
3937     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
3938                      newSVpvs(ATTRSMODULE),
3939                      NULL, op_prepend_elem(OP_LIST,
3940                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
3941                                   op_prepend_elem(OP_LIST,
3942                                                newSVOP(OP_CONST, 0,
3943                                                        newRV(MUTABLE_SV(cv))),
3944                                                attrs)));
3945 }
3946 
3947 STATIC void
S_move_proto_attr(pTHX_ OP ** proto,OP ** attrs,const GV * name,bool curstash)3948 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name,
3949                         bool curstash)
3950 {
3951     OP *new_proto = NULL;
3952     STRLEN pvlen;
3953     char *pv;
3954     OP *o;
3955 
3956     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
3957 
3958     if (!*attrs)
3959         return;
3960 
3961     o = *attrs;
3962     if (o->op_type == OP_CONST) {
3963         pv = SvPV(cSVOPo_sv, pvlen);
3964         if (memBEGINs(pv, pvlen, "prototype(")) {
3965             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3966             SV ** const tmpo = cSVOPx_svp(o);
3967             SvREFCNT_dec(cSVOPo_sv);
3968             *tmpo = tmpsv;
3969             new_proto = o;
3970             *attrs = NULL;
3971         }
3972     } else if (o->op_type == OP_LIST) {
3973         OP * lasto;
3974         assert(o->op_flags & OPf_KIDS);
3975         lasto = cLISTOPo->op_first;
3976         assert(lasto->op_type == OP_PUSHMARK);
3977         for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
3978             if (o->op_type == OP_CONST) {
3979                 pv = SvPV(cSVOPo_sv, pvlen);
3980                 if (memBEGINs(pv, pvlen, "prototype(")) {
3981                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
3982                     SV ** const tmpo = cSVOPx_svp(o);
3983                     SvREFCNT_dec(cSVOPo_sv);
3984                     *tmpo = tmpsv;
3985                     if (new_proto && ckWARN(WARN_MISC)) {
3986                         STRLEN new_len;
3987                         const char * newp = SvPV(cSVOPo_sv, new_len);
3988                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3989                             "Attribute prototype(%" UTF8f ") discards earlier prototype attribute in same sub",
3990                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
3991                         op_free(new_proto);
3992                     }
3993                     else if (new_proto)
3994                         op_free(new_proto);
3995                     new_proto = o;
3996                     /* excise new_proto from the list */
3997                     op_sibling_splice(*attrs, lasto, 1, NULL);
3998                     o = lasto;
3999                     continue;
4000                 }
4001             }
4002             lasto = o;
4003         }
4004         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
4005            would get pulled in with no real need */
4006         if (!OpHAS_SIBLING(cLISTOPx(*attrs)->op_first)) {
4007             op_free(*attrs);
4008             *attrs = NULL;
4009         }
4010     }
4011 
4012     if (new_proto) {
4013         SV *svname;
4014         if (isGV(name)) {
4015             svname = sv_newmortal();
4016             gv_efullname3(svname, name, NULL);
4017         }
4018         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
4019             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
4020         else
4021             svname = (SV *)name;
4022         if (ckWARN(WARN_ILLEGALPROTO))
4023             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE,
4024                                  curstash);
4025         if (*proto && ckWARN(WARN_PROTOTYPE)) {
4026             STRLEN old_len, new_len;
4027             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
4028             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
4029 
4030             if (curstash && svname == (SV *)name
4031              && !memchr(SvPVX(svname), ':', SvCUR(svname))) {
4032                 svname = sv_2mortal(newSVsv(PL_curstname));
4033                 sv_catpvs(svname, "::");
4034                 sv_catsv(svname, (SV *)name);
4035             }
4036 
4037             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
4038                 "Prototype '%" UTF8f "' overridden by attribute 'prototype(%" UTF8f ")'"
4039                 " in %" SVf,
4040                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
4041                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
4042                 SVfARG(svname));
4043         }
4044         if (*proto)
4045             op_free(*proto);
4046         *proto = new_proto;
4047     }
4048 }
4049 
4050 static void
S_cant_declare(pTHX_ OP * o)4051 S_cant_declare(pTHX_ OP *o)
4052 {
4053     if (o->op_type == OP_NULL
4054      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
4055         o = cUNOPo->op_first;
4056     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
4057                              o->op_type == OP_NULL
4058                                && o->op_flags & OPf_SPECIAL
4059                                  ? "do block"
4060                                  : OP_DESC(o),
4061                              PL_parser->in_my == KEY_our   ? "our"   :
4062                              PL_parser->in_my == KEY_state ? "state" :
4063                                                              "my"));
4064 }
4065 
4066 STATIC OP *
S_my_kid(pTHX_ OP * o,OP * attrs,OP ** imopsp)4067 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
4068 {
4069     I32 type;
4070     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
4071 
4072     PERL_ARGS_ASSERT_MY_KID;
4073 
4074     if (!o || (PL_parser && PL_parser->error_count))
4075         return o;
4076 
4077     type = o->op_type;
4078 
4079     if (OP_TYPE_IS_OR_WAS(o, OP_LIST)) {
4080         OP *kid;
4081         for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
4082             my_kid(kid, attrs, imopsp);
4083         return o;
4084     } else if (type == OP_UNDEF || type == OP_STUB) {
4085         return o;
4086     } else if (type == OP_RV2SV ||	/* "our" declaration */
4087                type == OP_RV2AV ||
4088                type == OP_RV2HV) {
4089         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
4090             S_cant_declare(aTHX_ o);
4091         } else if (attrs) {
4092             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
4093             assert(PL_parser);
4094             PL_parser->in_my = FALSE;
4095             PL_parser->in_my_stash = NULL;
4096             apply_attrs(GvSTASH(gv),
4097                         (type == OP_RV2SV ? GvSVn(gv) :
4098                          type == OP_RV2AV ? MUTABLE_SV(GvAVn(gv)) :
4099                          type == OP_RV2HV ? MUTABLE_SV(GvHVn(gv)) : MUTABLE_SV(gv)),
4100                         attrs);
4101         }
4102         o->op_private |= OPpOUR_INTRO;
4103         return o;
4104     }
4105     else if (type == OP_REFGEN || type == OP_SREFGEN) {
4106         if (!FEATURE_MYREF_IS_ENABLED)
4107             Perl_croak(aTHX_ "The experimental declared_refs "
4108                              "feature is not enabled");
4109         Perl_ck_warner_d(aTHX_
4110              packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
4111             "Declaring references is experimental");
4112         /* Kid is a nulled OP_LIST, handled above.  */
4113         my_kid(cUNOPo->op_first, attrs, imopsp);
4114         return o;
4115     }
4116     else if (type != OP_PADSV &&
4117              type != OP_PADAV &&
4118              type != OP_PADHV &&
4119              type != OP_PUSHMARK)
4120     {
4121         S_cant_declare(aTHX_ o);
4122         return o;
4123     }
4124     else if (attrs && type != OP_PUSHMARK) {
4125         HV *stash;
4126 
4127         assert(PL_parser);
4128         PL_parser->in_my = FALSE;
4129         PL_parser->in_my_stash = NULL;
4130 
4131         /* check for C<my Dog $spot> when deciding package */
4132         stash = PAD_COMPNAME_TYPE(o->op_targ);
4133         if (!stash)
4134             stash = PL_curstash;
4135         apply_attrs_my(stash, o, attrs, imopsp);
4136     }
4137     o->op_flags |= OPf_MOD;
4138     o->op_private |= OPpLVAL_INTRO;
4139     if (stately)
4140         o->op_private |= OPpPAD_STATE;
4141     return o;
4142 }
4143 
4144 OP *
Perl_my_attrs(pTHX_ OP * o,OP * attrs)4145 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
4146 {
4147     OP *rops;
4148     int maybe_scalar = 0;
4149 
4150     PERL_ARGS_ASSERT_MY_ATTRS;
4151 
4152 /* [perl #17376]: this appears to be premature, and results in code such as
4153    C< our(%x); > executing in list mode rather than void mode */
4154 #if 0
4155     if (o->op_flags & OPf_PARENS)
4156         list(o);
4157     else
4158         maybe_scalar = 1;
4159 #else
4160     maybe_scalar = 1;
4161 #endif
4162     if (attrs)
4163         SAVEFREEOP(attrs);
4164     rops = NULL;
4165     o = my_kid(o, attrs, &rops);
4166     if (rops) {
4167         if (maybe_scalar && o->op_type == OP_PADSV) {
4168             o = scalar(op_append_list(OP_LIST, rops, o));
4169             o->op_private |= OPpLVAL_INTRO;
4170         }
4171         else {
4172             /* The listop in rops might have a pushmark at the beginning,
4173                which will mess up list assignment. */
4174             LISTOP * const lrops = cLISTOPx(rops); /* for brevity */
4175             if (rops->op_type == OP_LIST &&
4176                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
4177             {
4178                 OP * const pushmark = lrops->op_first;
4179                 /* excise pushmark */
4180                 op_sibling_splice(rops, NULL, 1, NULL);
4181                 op_free(pushmark);
4182             }
4183             o = op_append_list(OP_LIST, o, rops);
4184         }
4185     }
4186     PL_parser->in_my = FALSE;
4187     PL_parser->in_my_stash = NULL;
4188     return o;
4189 }
4190 
4191 OP *
Perl_sawparens(pTHX_ OP * o)4192 Perl_sawparens(pTHX_ OP *o)
4193 {
4194     PERL_UNUSED_CONTEXT;
4195     if (o)
4196         o->op_flags |= OPf_PARENS;
4197     return o;
4198 }
4199 
4200 OP *
Perl_bind_match(pTHX_ I32 type,OP * left,OP * right)4201 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
4202 {
4203     OP *o;
4204     bool ismatchop = 0;
4205     const OPCODE ltype = left->op_type;
4206     const OPCODE rtype = right->op_type;
4207 
4208     PERL_ARGS_ASSERT_BIND_MATCH;
4209 
4210     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
4211           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
4212     {
4213       const char * const desc
4214           = PL_op_desc[(
4215                           rtype == OP_SUBST || rtype == OP_TRANS
4216                        || rtype == OP_TRANSR
4217                        )
4218                        ? (int)rtype : OP_MATCH];
4219       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
4220       SV * const name = op_varname(left);
4221       if (name)
4222         Perl_warner(aTHX_ packWARN(WARN_MISC),
4223              "Applying %s to %" SVf " will act on scalar(%" SVf ")",
4224              desc, SVfARG(name), SVfARG(name));
4225       else {
4226         const char * const sample = (isary
4227              ? "@array" : "%hash");
4228         Perl_warner(aTHX_ packWARN(WARN_MISC),
4229              "Applying %s to %s will act on scalar(%s)",
4230              desc, sample, sample);
4231       }
4232     }
4233 
4234     if (rtype == OP_CONST &&
4235         cSVOPx(right)->op_private & OPpCONST_BARE &&
4236         cSVOPx(right)->op_private & OPpCONST_STRICT)
4237     {
4238         no_bareword_allowed(right);
4239     }
4240 
4241     /* !~ doesn't make sense with /r, so error on it for now */
4242     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
4243         type == OP_NOT)
4244         /* diag_listed_as: Using !~ with %s doesn't make sense */
4245         yyerror("Using !~ with s///r doesn't make sense");
4246     if (rtype == OP_TRANSR && type == OP_NOT)
4247         /* diag_listed_as: Using !~ with %s doesn't make sense */
4248         yyerror("Using !~ with tr///r doesn't make sense");
4249 
4250     ismatchop = (rtype == OP_MATCH ||
4251                  rtype == OP_SUBST ||
4252                  rtype == OP_TRANS || rtype == OP_TRANSR)
4253              && !(right->op_flags & OPf_SPECIAL);
4254     if (ismatchop && right->op_private & OPpTARGET_MY) {
4255         right->op_targ = 0;
4256         right->op_private &= ~OPpTARGET_MY;
4257     }
4258     if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
4259         if (left->op_type == OP_PADSV
4260          && !(left->op_private & OPpLVAL_INTRO))
4261         {
4262             right->op_targ = left->op_targ;
4263             op_free(left);
4264             o = right;
4265         }
4266         else {
4267             right->op_flags |= OPf_STACKED;
4268             if (rtype != OP_MATCH && rtype != OP_TRANSR &&
4269             ! (rtype == OP_TRANS &&
4270                right->op_private & OPpTRANS_IDENTICAL) &&
4271             ! (rtype == OP_SUBST &&
4272                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
4273                 left = op_lvalue(left, rtype);
4274             if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
4275                 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
4276             else
4277                 o = op_prepend_elem(rtype, scalar(left), right);
4278         }
4279         if (type == OP_NOT)
4280             return newUNOP(OP_NOT, 0, scalar(o));
4281         return o;
4282     }
4283     else
4284         return bind_match(type, left,
4285                 pmruntime(newPMOP(OP_MATCH, 0), right, NULL, 0, 0));
4286 }
4287 
4288 OP *
Perl_invert(pTHX_ OP * o)4289 Perl_invert(pTHX_ OP *o)
4290 {
4291     if (!o)
4292         return NULL;
4293     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
4294 }
4295 
4296 OP *
Perl_cmpchain_start(pTHX_ I32 type,OP * left,OP * right)4297 Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right)
4298 {
4299     BINOP *bop;
4300     OP *op;
4301 
4302     if (!left)
4303         left = newOP(OP_NULL, 0);
4304     if (!right)
4305         right = newOP(OP_NULL, 0);
4306     scalar(left);
4307     scalar(right);
4308     NewOp(0, bop, 1, BINOP);
4309     op = (OP*)bop;
4310     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4311     OpTYPE_set(op, type);
4312     cBINOPx(op)->op_flags = OPf_KIDS;
4313     cBINOPx(op)->op_private = 2;
4314     cBINOPx(op)->op_first = left;
4315     cBINOPx(op)->op_last = right;
4316     OpMORESIB_set(left, right);
4317     OpLASTSIB_set(right, op);
4318     return op;
4319 }
4320 
4321 OP *
Perl_cmpchain_extend(pTHX_ I32 type,OP * ch,OP * right)4322 Perl_cmpchain_extend(pTHX_ I32 type, OP *ch, OP *right)
4323 {
4324     BINOP *bop;
4325     OP *op;
4326 
4327     PERL_ARGS_ASSERT_CMPCHAIN_EXTEND;
4328     if (!right)
4329         right = newOP(OP_NULL, 0);
4330     scalar(right);
4331     NewOp(0, bop, 1, BINOP);
4332     op = (OP*)bop;
4333     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP);
4334     OpTYPE_set(op, type);
4335     if (ch->op_type != OP_NULL) {
4336         UNOP *lch;
4337         OP *nch, *cleft, *cright;
4338         NewOp(0, lch, 1, UNOP);
4339         nch = (OP*)lch;
4340         OpTYPE_set(nch, OP_NULL);
4341         nch->op_flags = OPf_KIDS;
4342         cleft = cBINOPx(ch)->op_first;
4343         cright = cBINOPx(ch)->op_last;
4344         cBINOPx(ch)->op_first = NULL;
4345         cBINOPx(ch)->op_last = NULL;
4346         cBINOPx(ch)->op_private = 0;
4347         cBINOPx(ch)->op_flags = 0;
4348         cUNOPx(nch)->op_first = cright;
4349         OpMORESIB_set(cright, ch);
4350         OpMORESIB_set(ch, cleft);
4351         OpLASTSIB_set(cleft, nch);
4352         ch = nch;
4353     }
4354     OpMORESIB_set(right, op);
4355     OpMORESIB_set(op, cUNOPx(ch)->op_first);
4356     cUNOPx(ch)->op_first = right;
4357     return ch;
4358 }
4359 
4360 OP *
Perl_cmpchain_finish(pTHX_ OP * ch)4361 Perl_cmpchain_finish(pTHX_ OP *ch)
4362 {
4363 
4364     PERL_ARGS_ASSERT_CMPCHAIN_FINISH;
4365     if (ch->op_type != OP_NULL) {
4366         OPCODE cmpoptype = ch->op_type;
4367         ch = CHECKOP(cmpoptype, ch);
4368         if(!ch->op_next && ch->op_type == cmpoptype)
4369             ch = fold_constants(op_integerize(op_std_init(ch)));
4370         return ch;
4371     } else {
4372         OP *condop = NULL;
4373         OP *rightarg = cUNOPx(ch)->op_first;
4374         cUNOPx(ch)->op_first = OpSIBLING(rightarg);
4375         OpLASTSIB_set(rightarg, NULL);
4376         while (1) {
4377             OP *cmpop = cUNOPx(ch)->op_first;
4378             OP *leftarg = OpSIBLING(cmpop);
4379             OPCODE cmpoptype = cmpop->op_type;
4380             OP *nextrightarg;
4381             bool is_last;
4382             is_last = !(cUNOPx(ch)->op_first = OpSIBLING(leftarg));
4383             OpLASTSIB_set(cmpop, NULL);
4384             OpLASTSIB_set(leftarg, NULL);
4385             if (is_last) {
4386                 ch->op_flags = 0;
4387                 op_free(ch);
4388                 nextrightarg = NULL;
4389             } else {
4390                 nextrightarg = newUNOP(OP_CMPCHAIN_DUP, 0, leftarg);
4391                 leftarg = newOP(OP_NULL, 0);
4392             }
4393             cBINOPx(cmpop)->op_first = leftarg;
4394             cBINOPx(cmpop)->op_last = rightarg;
4395             OpMORESIB_set(leftarg, rightarg);
4396             OpLASTSIB_set(rightarg, cmpop);
4397             cmpop->op_flags = OPf_KIDS;
4398             cmpop->op_private = 2;
4399             cmpop = CHECKOP(cmpoptype, cmpop);
4400             if(!cmpop->op_next && cmpop->op_type == cmpoptype)
4401                 cmpop = op_integerize(op_std_init(cmpop));
4402             condop = condop ? newLOGOP(OP_CMPCHAIN_AND, 0, cmpop, condop) :
4403                         cmpop;
4404             if (!nextrightarg)
4405                 return condop;
4406             rightarg = nextrightarg;
4407         }
4408     }
4409 }
4410 
4411 /*
4412 =for apidoc op_scope
4413 
4414 Wraps up an op tree with some additional ops so that at runtime a dynamic
4415 scope will be created.  The original ops run in the new dynamic scope,
4416 and then, provided that they exit normally, the scope will be unwound.
4417 The additional ops used to create and unwind the dynamic scope will
4418 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
4419 instead if the ops are simple enough to not need the full dynamic scope
4420 structure.
4421 
4422 =cut
4423 */
4424 
4425 OP *
Perl_op_scope(pTHX_ OP * o)4426 Perl_op_scope(pTHX_ OP *o)
4427 {
4428     if (o) {
4429         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
4430             o = op_prepend_elem(OP_LINESEQ,
4431                     newOP(OP_ENTER, (o->op_flags & OPf_WANT)), o);
4432             OpTYPE_set(o, OP_LEAVE);
4433         }
4434         else if (o->op_type == OP_LINESEQ) {
4435             OP *kid;
4436             OpTYPE_set(o, OP_SCOPE);
4437             kid = cLISTOPo->op_first;
4438             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
4439                 op_null(kid);
4440 
4441                 /* The following deals with things like 'do {1 for 1}' */
4442                 kid = OpSIBLING(kid);
4443                 if (kid &&
4444                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
4445                     op_null(kid);
4446             }
4447         }
4448         else
4449             o = newLISTOP(OP_SCOPE, 0, o, NULL);
4450     }
4451     return o;
4452 }
4453 
4454 OP *
Perl_op_unscope(pTHX_ OP * o)4455 Perl_op_unscope(pTHX_ OP *o)
4456 {
4457     if (o && o->op_type == OP_LINESEQ) {
4458         OP *kid = cLISTOPo->op_first;
4459         for(; kid; kid = OpSIBLING(kid))
4460             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
4461                 op_null(kid);
4462     }
4463     return o;
4464 }
4465 
4466 /*
4467 =for apidoc block_start
4468 
4469 Handles compile-time scope entry.
4470 Arranges for hints to be restored on block
4471 exit and also handles pad sequence numbers to make lexical variables scope
4472 right.  Returns a savestack index for use with C<block_end>.
4473 
4474 =cut
4475 */
4476 
4477 int
Perl_block_start(pTHX_ int full)4478 Perl_block_start(pTHX_ int full)
4479 {
4480     const int retval = PL_savestack_ix;
4481 
4482     PL_compiling.cop_seq = PL_cop_seqmax;
4483     COP_SEQMAX_INC;
4484     pad_block_start(full);
4485     SAVEHINTS();
4486     PL_hints &= ~HINT_BLOCK_SCOPE;
4487     SAVECOMPILEWARNINGS();
4488     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
4489     SAVEI32(PL_compiling.cop_seq);
4490     PL_compiling.cop_seq = 0;
4491 
4492     CALL_BLOCK_HOOKS(bhk_start, full);
4493 
4494     return retval;
4495 }
4496 
4497 /*
4498 =for apidoc block_end
4499 
4500 Handles compile-time scope exit.  C<floor>
4501 is the savestack index returned by
4502 C<block_start>, and C<seq> is the body of the block.  Returns the block,
4503 possibly modified.
4504 
4505 =cut
4506 */
4507 
4508 OP*
Perl_block_end(pTHX_ I32 floor,OP * seq)4509 Perl_block_end(pTHX_ I32 floor, OP *seq)
4510 {
4511     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
4512     OP* retval = voidnonfinal(seq);
4513     OP *o;
4514 
4515     /* XXX Is the null PL_parser check necessary here? */
4516     assert(PL_parser); /* Let’s find out under debugging builds.  */
4517     if (PL_parser && PL_parser->parsed_sub) {
4518         o = newSTATEOP(0, NULL, NULL);
4519         op_null(o);
4520         retval = op_append_elem(OP_LINESEQ, retval, o);
4521     }
4522 
4523     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
4524 
4525     LEAVE_SCOPE(floor);
4526     if (needblockscope)
4527         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
4528     o = pad_leavemy();
4529 
4530     if (o) {
4531         /* pad_leavemy has created a sequence of introcv ops for all my
4532            subs declared in the block.  We have to replicate that list with
4533            clonecv ops, to deal with this situation:
4534 
4535                sub {
4536                    my sub s1;
4537                    my sub s2;
4538                    sub s1 { state sub foo { \&s2 } }
4539                }->()
4540 
4541            Originally, I was going to have introcv clone the CV and turn
4542            off the stale flag.  Since &s1 is declared before &s2, the
4543            introcv op for &s1 is executed (on sub entry) before the one for
4544            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
4545            cloned, since it is a state sub) closes over &s2 and expects
4546            to see it in its outer CV’s pad.  If the introcv op clones &s1,
4547            then &s2 is still marked stale.  Since &s1 is not active, and
4548            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
4549            ble will not stay shared’ warning.  Because it is the same stub
4550            that will be used when the introcv op for &s2 is executed, clos-
4551            ing over it is safe.  Hence, we have to turn off the stale flag
4552            on all lexical subs in the block before we clone any of them.
4553            Hence, having introcv clone the sub cannot work.  So we create a
4554            list of ops like this:
4555 
4556                lineseq
4557                   |
4558                   +-- introcv
4559                   |
4560                   +-- introcv
4561                   |
4562                   +-- introcv
4563                   |
4564                   .
4565                   .
4566                   .
4567                   |
4568                   +-- clonecv
4569                   |
4570                   +-- clonecv
4571                   |
4572                   +-- clonecv
4573                   |
4574                   .
4575                   .
4576                   .
4577          */
4578         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
4579         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
4580         for (;; kid = OpSIBLING(kid)) {
4581             OP *newkid = newOP(OP_CLONECV, 0);
4582             newkid->op_targ = kid->op_targ;
4583             o = op_append_elem(OP_LINESEQ, o, newkid);
4584             if (kid == last) break;
4585         }
4586         retval = op_prepend_elem(OP_LINESEQ, o, retval);
4587     }
4588 
4589     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
4590 
4591     return retval;
4592 }
4593 
4594 /*
4595 =for apidoc_section $scope
4596 
4597 =for apidoc blockhook_register
4598 
4599 Register a set of hooks to be called when the Perl lexical scope changes
4600 at compile time.  See L<perlguts/"Compile-time scope hooks">.
4601 
4602 =cut
4603 */
4604 
4605 void
Perl_blockhook_register(pTHX_ BHK * hk)4606 Perl_blockhook_register(pTHX_ BHK *hk)
4607 {
4608     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
4609 
4610     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
4611 }
4612 
4613 void
Perl_newPROG(pTHX_ OP * o)4614 Perl_newPROG(pTHX_ OP *o)
4615 {
4616     OP *start;
4617 
4618     PERL_ARGS_ASSERT_NEWPROG;
4619 
4620     if (PL_in_eval) {
4621         PERL_CONTEXT *cx;
4622         I32 i;
4623         if (PL_eval_root)
4624                 return;
4625         PL_eval_root = newUNOP(OP_LEAVEEVAL,
4626                                ((PL_in_eval & EVAL_KEEPERR)
4627                                 ? OPf_SPECIAL : 0), o);
4628 
4629         cx = CX_CUR();
4630         assert(CxTYPE(cx) == CXt_EVAL);
4631 
4632         if ((cx->blk_gimme & G_WANT) == G_VOID)
4633             scalarvoid(PL_eval_root);
4634         else if ((cx->blk_gimme & G_WANT) == G_LIST)
4635             list(PL_eval_root);
4636         else
4637             scalar(PL_eval_root);
4638 
4639         start = op_linklist(PL_eval_root);
4640         PL_eval_root->op_next = 0;
4641         i = PL_savestack_ix;
4642         SAVEFREEOP(o);
4643         ENTER;
4644         S_process_optree(aTHX_ NULL, PL_eval_root, start);
4645         LEAVE;
4646         PL_savestack_ix = i;
4647     }
4648     else {
4649         if (o->op_type == OP_STUB) {
4650             /* This block is entered if nothing is compiled for the main
4651                program. This will be the case for an genuinely empty main
4652                program, or one which only has BEGIN blocks etc, so already
4653                run and freed.
4654 
4655                Historically (5.000) the guard above was !o. However, commit
4656                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
4657                c71fccf11fde0068, changed perly.y so that newPROG() is now
4658                called with the output of block_end(), which returns a new
4659                OP_STUB for the case of an empty optree. ByteLoader (and
4660                maybe other things) also take this path, because they set up
4661                PL_main_start and PL_main_root directly, without generating an
4662                optree.
4663 
4664                If the parsing the main program aborts (due to parse errors,
4665                or due to BEGIN or similar calling exit), then newPROG()
4666                isn't even called, and hence this code path and its cleanups
4667                are skipped. This shouldn't make a make a difference:
4668                * a non-zero return from perl_parse is a failure, and
4669                  perl_destruct() should be called immediately.
4670                * however, if exit(0) is called during the parse, then
4671                  perl_parse() returns 0, and perl_run() is called. As
4672                  PL_main_start will be NULL, perl_run() will return
4673                  promptly, and the exit code will remain 0.
4674             */
4675 
4676             PL_comppad_name = 0;
4677             PL_compcv = 0;
4678             S_op_destroy(aTHX_ o);
4679             return;
4680         }
4681         PL_main_root = op_scope(sawparens(scalarvoid(o)));
4682         PL_curcop = &PL_compiling;
4683         start = LINKLIST(PL_main_root);
4684         PL_main_root->op_next = 0;
4685         S_process_optree(aTHX_ NULL, PL_main_root, start);
4686         if (!PL_parser->error_count)
4687             /* on error, leave CV slabbed so that ops left lying around
4688              * will eb cleaned up. Else unslab */
4689             cv_forget_slab(PL_compcv);
4690         PL_compcv = 0;
4691 
4692         /* Register with debugger */
4693         if (PERLDB_INTER) {
4694             CV * const cv = get_cvs("DB::postponed", 0);
4695             if (cv) {
4696                 dSP;
4697                 PUSHMARK(SP);
4698                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4699                 PUTBACK;
4700                 call_sv(MUTABLE_SV(cv), G_DISCARD);
4701             }
4702         }
4703     }
4704 }
4705 
4706 OP *
Perl_localize(pTHX_ OP * o,I32 lex)4707 Perl_localize(pTHX_ OP *o, I32 lex)
4708 {
4709     PERL_ARGS_ASSERT_LOCALIZE;
4710 
4711     if (o->op_flags & OPf_PARENS)
4712 /* [perl #17376]: this appears to be premature, and results in code such as
4713    C< our(%x); > executing in list mode rather than void mode */
4714 #if 0
4715         list(o);
4716 #else
4717         NOOP;
4718 #endif
4719     else {
4720         if ( PL_parser->bufptr > PL_parser->oldbufptr
4721             && PL_parser->bufptr[-1] == ','
4722             && ckWARN(WARN_PARENTHESIS))
4723         {
4724             char *s = PL_parser->bufptr;
4725             bool sigil = FALSE;
4726 
4727             /* some heuristics to detect a potential error */
4728             while (*s && (memCHRs(", \t\n", *s)))
4729                 s++;
4730 
4731             while (1) {
4732                 if (*s && (memCHRs("@$%", *s) || (!lex && *s == '*'))
4733                        && *++s
4734                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
4735                     s++;
4736                     sigil = TRUE;
4737                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
4738                         s++;
4739                     while (*s && (memCHRs(", \t\n", *s)))
4740                         s++;
4741                 }
4742                 else
4743                     break;
4744             }
4745             if (sigil && (*s == ';' || *s == '=')) {
4746                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
4747                                 "Parentheses missing around \"%s\" list",
4748                                 lex
4749                                     ? (PL_parser->in_my == KEY_our
4750                                         ? "our"
4751                                         : PL_parser->in_my == KEY_state
4752                                             ? "state"
4753                                             : "my")
4754                                     : "local");
4755             }
4756         }
4757     }
4758     if (lex)
4759         o = my(o);
4760     else
4761         o = op_lvalue(o, OP_NULL);		/* a bit kludgey */
4762     PL_parser->in_my = FALSE;
4763     PL_parser->in_my_stash = NULL;
4764     return o;
4765 }
4766 
4767 OP *
Perl_jmaybe(pTHX_ OP * o)4768 Perl_jmaybe(pTHX_ OP *o)
4769 {
4770     PERL_ARGS_ASSERT_JMAYBE;
4771 
4772     if (o->op_type == OP_LIST) {
4773         if (FEATURE_MULTIDIMENSIONAL_IS_ENABLED) {
4774             OP * const o2
4775                 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
4776             o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
4777         }
4778         else {
4779             /* If the user disables this, then a warning might not be enough to alert
4780                them to a possible change of behaviour here, so throw an exception.
4781             */
4782             yyerror("Multidimensional hash lookup is disabled");
4783         }
4784     }
4785     return o;
4786 }
4787 
4788 PERL_STATIC_INLINE OP *
S_op_std_init(pTHX_ OP * o)4789 S_op_std_init(pTHX_ OP *o)
4790 {
4791     I32 type = o->op_type;
4792 
4793     PERL_ARGS_ASSERT_OP_STD_INIT;
4794 
4795     if (PL_opargs[type] & OA_RETSCALAR)
4796         scalar(o);
4797     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
4798         o->op_targ = pad_alloc(type, SVs_PADTMP);
4799 
4800     return o;
4801 }
4802 
4803 PERL_STATIC_INLINE OP *
S_op_integerize(pTHX_ OP * o)4804 S_op_integerize(pTHX_ OP *o)
4805 {
4806     I32 type = o->op_type;
4807 
4808     PERL_ARGS_ASSERT_OP_INTEGERIZE;
4809 
4810     /* integerize op. */
4811     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
4812     {
4813         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
4814     }
4815 
4816     if (type == OP_NEGATE)
4817         /* XXX might want a ck_negate() for this */
4818         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
4819 
4820     return o;
4821 }
4822 
4823 /* This function exists solely to provide a scope to limit
4824    setjmp/longjmp() messing with auto variables.  It cannot be inlined because
4825    it uses setjmp
4826  */
4827 STATIC int
S_fold_constants_eval(pTHX)4828 S_fold_constants_eval(pTHX) {
4829     int ret = 0;
4830     dJMPENV;
4831 
4832     JMPENV_PUSH(ret);
4833 
4834     if (ret == 0) {
4835         CALLRUNOPS(aTHX);
4836     }
4837 
4838     JMPENV_POP;
4839 
4840     return ret;
4841 }
4842 
4843 static OP *
S_fold_constants(pTHX_ OP * const o)4844 S_fold_constants(pTHX_ OP *const o)
4845 {
4846     OP *curop;
4847     OP *newop;
4848     I32 type = o->op_type;
4849     bool is_stringify;
4850     SV *sv = NULL;
4851     int ret = 0;
4852     OP *old_next;
4853     SV * const oldwarnhook = PL_warnhook;
4854     SV * const olddiehook  = PL_diehook;
4855     COP not_compiling;
4856     U8 oldwarn = PL_dowarn;
4857     I32 old_cxix;
4858 
4859     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
4860 
4861     if (!(PL_opargs[type] & OA_FOLDCONST))
4862         goto nope;
4863 
4864     switch (type) {
4865     case OP_UCFIRST:
4866     case OP_LCFIRST:
4867     case OP_UC:
4868     case OP_LC:
4869     case OP_FC:
4870 #ifdef USE_LOCALE_CTYPE
4871         if (IN_LC_COMPILETIME(LC_CTYPE))
4872             goto nope;
4873 #endif
4874         break;
4875     case OP_SLT:
4876     case OP_SGT:
4877     case OP_SLE:
4878     case OP_SGE:
4879     case OP_SCMP:
4880 #ifdef USE_LOCALE_COLLATE
4881         if (IN_LC_COMPILETIME(LC_COLLATE))
4882             goto nope;
4883 #endif
4884         break;
4885     case OP_SPRINTF:
4886         /* XXX what about the numeric ops? */
4887 #ifdef USE_LOCALE_NUMERIC
4888         if (IN_LC_COMPILETIME(LC_NUMERIC))
4889             goto nope;
4890 #endif
4891         break;
4892     case OP_PACK:
4893         if (!OpHAS_SIBLING(cLISTOPo->op_first)
4894           || OpSIBLING(cLISTOPo->op_first)->op_type != OP_CONST)
4895             goto nope;
4896         {
4897             SV * const sv = cSVOPx_sv(OpSIBLING(cLISTOPo->op_first));
4898             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
4899             {
4900                 const char *s = SvPVX_const(sv);
4901                 while (s < SvEND(sv)) {
4902                     if (isALPHA_FOLD_EQ(*s, 'p')) goto nope;
4903                     s++;
4904                 }
4905             }
4906         }
4907         break;
4908     case OP_REPEAT:
4909         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
4910         break;
4911     case OP_SREFGEN:
4912         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
4913          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
4914             goto nope;
4915     }
4916 
4917     if (PL_parser && PL_parser->error_count)
4918         goto nope;		/* Don't try to run w/ errors */
4919 
4920     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4921         switch (curop->op_type) {
4922         case OP_CONST:
4923             if (   (curop->op_private & OPpCONST_BARE)
4924                 && (curop->op_private & OPpCONST_STRICT)) {
4925                 no_bareword_allowed(curop);
4926                 goto nope;
4927             }
4928             /* FALLTHROUGH */
4929         case OP_LIST:
4930         case OP_SCALAR:
4931         case OP_NULL:
4932         case OP_PUSHMARK:
4933             /* Foldable; move to next op in list */
4934             break;
4935 
4936         default:
4937             /* No other op types are considered foldable */
4938             goto nope;
4939         }
4940     }
4941 
4942     curop = LINKLIST(o);
4943     old_next = o->op_next;
4944     o->op_next = 0;
4945     PL_op = curop;
4946 
4947     old_cxix = cxstack_ix;
4948     create_eval_scope(NULL, G_FAKINGEVAL);
4949 
4950     /* Verify that we don't need to save it:  */
4951     assert(PL_curcop == &PL_compiling);
4952     StructCopy(&PL_compiling, &not_compiling, COP);
4953     PL_curcop = &not_compiling;
4954     /* The above ensures that we run with all the correct hints of the
4955        currently compiling COP, but that IN_PERL_RUNTIME is true. */
4956     assert(IN_PERL_RUNTIME);
4957     PL_warnhook = PERL_WARNHOOK_FATAL;
4958     PL_diehook  = NULL;
4959 
4960     /* Effective $^W=1.  */
4961     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
4962         PL_dowarn |= G_WARN_ON;
4963 
4964     ret = S_fold_constants_eval(aTHX);
4965 
4966     switch (ret) {
4967     case 0:
4968         sv = *(PL_stack_sp--);
4969         if (o->op_targ && sv == PAD_SV(o->op_targ)) {	/* grab pad temp? */
4970             pad_swipe(o->op_targ,  FALSE);
4971         }
4972         else if (SvTEMP(sv)) {			/* grab mortal temp? */
4973             SvREFCNT_inc_simple_void(sv);
4974             SvTEMP_off(sv);
4975         }
4976         else { assert(SvIMMORTAL(sv)); }
4977         break;
4978     case 3:
4979         /* Something tried to die.  Abandon constant folding.  */
4980         /* Pretend the error never happened.  */
4981         CLEAR_ERRSV();
4982         o->op_next = old_next;
4983         break;
4984     default:
4985         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
4986         PL_warnhook = oldwarnhook;
4987         PL_diehook  = olddiehook;
4988         /* XXX note that this croak may fail as we've already blown away
4989          * the stack - eg any nested evals */
4990         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
4991     }
4992     PL_dowarn   = oldwarn;
4993     PL_warnhook = oldwarnhook;
4994     PL_diehook  = olddiehook;
4995     PL_curcop = &PL_compiling;
4996 
4997     /* if we croaked, depending on how we croaked the eval scope
4998      * may or may not have already been popped */
4999     if (cxstack_ix > old_cxix) {
5000         assert(cxstack_ix == old_cxix + 1);
5001         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5002         delete_eval_scope();
5003     }
5004     if (ret)
5005         goto nope;
5006 
5007     /* OP_STRINGIFY and constant folding are used to implement qq.
5008        Here the constant folding is an implementation detail that we
5009        want to hide.  If the stringify op is itself already marked
5010        folded, however, then it is actually a folded join.  */
5011     is_stringify = type == OP_STRINGIFY && !o->op_folded;
5012     op_free(o);
5013     assert(sv);
5014     if (is_stringify)
5015         SvPADTMP_off(sv);
5016     else if (!SvIMMORTAL(sv)) {
5017         SvPADTMP_on(sv);
5018         SvREADONLY_on(sv);
5019     }
5020     newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
5021     if (!is_stringify) newop->op_folded = 1;
5022     return newop;
5023 
5024  nope:
5025     return o;
5026 }
5027 
5028 /* convert a constant range in list context into an OP_RV2AV, OP_CONST pair;
5029  * the constant value being an AV holding the flattened range.
5030  */
5031 
5032 static void
S_gen_constant_list(pTHX_ OP * o)5033 S_gen_constant_list(pTHX_ OP *o)
5034 {
5035     OP *curop, *old_next;
5036     SV * const oldwarnhook = PL_warnhook;
5037     SV * const olddiehook  = PL_diehook;
5038     COP *old_curcop;
5039     U8 oldwarn = PL_dowarn;
5040     SV **svp;
5041     AV *av;
5042     I32 old_cxix;
5043     COP not_compiling;
5044     int ret = 0;
5045     dJMPENV;
5046     bool op_was_null;
5047 
5048     list(o);
5049     if (PL_parser && PL_parser->error_count)
5050         return;		/* Don't attempt to run with errors */
5051 
5052     curop = LINKLIST(o);
5053     old_next = o->op_next;
5054     o->op_next = 0;
5055     op_was_null = o->op_type == OP_NULL;
5056     if (op_was_null) /* b3698342565fb462291fba4b432cfcd05b6eb4e1 */
5057         o->op_type = OP_CUSTOM;
5058     CALL_PEEP(curop);
5059     if (op_was_null)
5060         o->op_type = OP_NULL;
5061     op_prune_chain_head(&curop);
5062     PL_op = curop;
5063 
5064     old_cxix = cxstack_ix;
5065     create_eval_scope(NULL, G_FAKINGEVAL);
5066 
5067     old_curcop = PL_curcop;
5068     StructCopy(old_curcop, &not_compiling, COP);
5069     PL_curcop = &not_compiling;
5070     /* The above ensures that we run with all the correct hints of the
5071        current COP, but that IN_PERL_RUNTIME is true. */
5072     assert(IN_PERL_RUNTIME);
5073     PL_warnhook = PERL_WARNHOOK_FATAL;
5074     PL_diehook  = NULL;
5075     JMPENV_PUSH(ret);
5076 
5077     /* Effective $^W=1.  */
5078     if ( ! (PL_dowarn & G_WARN_ALL_MASK))
5079         PL_dowarn |= G_WARN_ON;
5080 
5081     switch (ret) {
5082     case 0:
5083 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
5084         PL_curstackinfo->si_stack_hwm = 0; /* stop valgrind complaining */
5085 #endif
5086         Perl_pp_pushmark(aTHX);
5087         CALLRUNOPS(aTHX);
5088         PL_op = curop;
5089         assert (!(curop->op_flags & OPf_SPECIAL));
5090         assert(curop->op_type == OP_RANGE);
5091         Perl_pp_anonlist(aTHX);
5092         break;
5093     case 3:
5094         CLEAR_ERRSV();
5095         o->op_next = old_next;
5096         break;
5097     default:
5098         JMPENV_POP;
5099         PL_warnhook = oldwarnhook;
5100         PL_diehook = olddiehook;
5101         Perl_croak(aTHX_ "panic: gen_constant_list JMPENV_PUSH returned %d",
5102             ret);
5103     }
5104 
5105     JMPENV_POP;
5106     PL_dowarn = oldwarn;
5107     PL_warnhook = oldwarnhook;
5108     PL_diehook = olddiehook;
5109     PL_curcop = old_curcop;
5110 
5111     if (cxstack_ix > old_cxix) {
5112         assert(cxstack_ix == old_cxix + 1);
5113         assert(CxTYPE(CX_CUR()) == CXt_EVAL);
5114         delete_eval_scope();
5115     }
5116     if (ret)
5117         return;
5118 
5119     OpTYPE_set(o, OP_RV2AV);
5120     o->op_flags &= ~OPf_REF;	/* treat \(1..2) like an ordinary list */
5121     o->op_flags |= OPf_PARENS;	/* and flatten \(1..2,3) */
5122     o->op_opt = 0;		/* needs to be revisited in rpeep() */
5123     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
5124 
5125     /* replace subtree with an OP_CONST */
5126     curop = cUNOPo->op_first;
5127     op_sibling_splice(o, NULL, -1, newSVOP(OP_CONST, 0, (SV *)av));
5128     op_free(curop);
5129 
5130     if (AvFILLp(av) != -1)
5131         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
5132         {
5133             SvPADTMP_on(*svp);
5134             SvREADONLY_on(*svp);
5135         }
5136     LINKLIST(o);
5137     list(o);
5138     return;
5139 }
5140 
5141 /*
5142 =for apidoc_section $optree_manipulation
5143 */
5144 
5145 enum {
5146     FORBID_LOOPEX_DEFAULT = (1<<0),
5147 };
5148 
walk_ops_find_labels(pTHX_ OP * o,HV * gotolabels)5149 static void walk_ops_find_labels(pTHX_ OP *o, HV *gotolabels)
5150 {
5151     switch(o->op_type) {
5152         case OP_NEXTSTATE:
5153         case OP_DBSTATE:
5154             {
5155                 STRLEN label_len;
5156                 U32 label_flags;
5157                 const char *label_pv = CopLABEL_len_flags((COP *)o, &label_len, &label_flags);
5158                 if(!label_pv)
5159                     break;
5160 
5161                 SV *labelsv = newSVpvn_flags(label_pv, label_len, label_flags);
5162                 SAVEFREESV(labelsv);
5163 
5164                 sv_inc(HeVAL(hv_fetch_ent(gotolabels, labelsv, TRUE, 0)));
5165                 break;
5166             }
5167     }
5168 
5169     if(!(o->op_flags & OPf_KIDS))
5170         return;
5171 
5172     OP *kid = cUNOPo->op_first;
5173     while(kid) {
5174         walk_ops_find_labels(aTHX_ kid, gotolabels);
5175         kid = OpSIBLING(kid);
5176     }
5177 }
5178 
walk_ops_forbid(pTHX_ OP * o,U32 flags,HV * permittedloops,HV * permittedgotos,const char * blockname)5179 static void walk_ops_forbid(pTHX_ OP *o, U32 flags, HV *permittedloops, HV *permittedgotos, const char *blockname)
5180 {
5181     bool is_loop = FALSE;
5182     SV *labelsv = NULL;
5183 
5184     switch(o->op_type) {
5185         case OP_NEXTSTATE:
5186         case OP_DBSTATE:
5187             PL_curcop = (COP *)o;
5188             return;
5189 
5190         case OP_RETURN:
5191             goto forbid;
5192 
5193         case OP_GOTO:
5194             {
5195                 /* OPf_STACKED means either dynamically computed label or `goto &sub` */
5196                 if(o->op_flags & OPf_STACKED)
5197                     goto forbid;
5198 
5199                 SV *target = newSVpvn_utf8(cPVOPo->op_pv, strlen(cPVOPo->op_pv),
5200                         cPVOPo->op_private & OPpPV_IS_UTF8);
5201                 SAVEFREESV(target);
5202 
5203                 if(hv_fetch_ent(permittedgotos, target, FALSE, 0))
5204                     break;
5205 
5206                 goto forbid;
5207             }
5208 
5209         case OP_NEXT:
5210         case OP_LAST:
5211         case OP_REDO:
5212             {
5213                 /* OPf_SPECIAL means this is a default loopex */
5214                 if(o->op_flags & OPf_SPECIAL) {
5215                     if(flags & FORBID_LOOPEX_DEFAULT)
5216                         goto forbid;
5217 
5218                     break;
5219                 }
5220                 /* OPf_STACKED means it's a dynamically computed label */
5221                 if(o->op_flags & OPf_STACKED)
5222                     goto forbid;
5223 
5224                 SV *target = newSVpv(cPVOPo->op_pv, strlen(cPVOPo->op_pv));
5225                 if(cPVOPo->op_private & OPpPV_IS_UTF8)
5226                     SvUTF8_on(target);
5227                 SAVEFREESV(target);
5228 
5229                 if(hv_fetch_ent(permittedloops, target, FALSE, 0))
5230                     break;
5231 
5232                 goto forbid;
5233             }
5234 
5235         case OP_LEAVELOOP:
5236             {
5237                 STRLEN label_len;
5238                 U32 label_flags;
5239                 const char *label_pv = CopLABEL_len_flags(PL_curcop, &label_len, &label_flags);
5240 
5241                 if(label_pv) {
5242                     labelsv = newSVpvn(label_pv, label_len);
5243                     if(label_flags & SVf_UTF8)
5244                         SvUTF8_on(labelsv);
5245                     SAVEFREESV(labelsv);
5246 
5247                     sv_inc(HeVAL(hv_fetch_ent(permittedloops, labelsv, TRUE, 0)));
5248                 }
5249 
5250                 is_loop = TRUE;
5251                 break;
5252             }
5253 
5254 forbid:
5255             /* diag_listed_as: Can't "%s" out of a "defer" block */
5256             /* diag_listed_as: Can't "%s" out of a "finally" block */
5257             croak("Can't \"%s\" out of %s", PL_op_name[o->op_type], blockname);
5258 
5259         default:
5260             break;
5261     }
5262 
5263     if(!(o->op_flags & OPf_KIDS))
5264         return;
5265 
5266     OP *kid = cUNOPo->op_first;
5267     while(kid) {
5268         walk_ops_forbid(aTHX_ kid, flags, permittedloops, permittedgotos, blockname);
5269         kid = OpSIBLING(kid);
5270 
5271         if(is_loop) {
5272             /* Now in the body of the loop; we can permit loopex default */
5273             flags &= ~FORBID_LOOPEX_DEFAULT;
5274         }
5275     }
5276 
5277     if(is_loop && labelsv) {
5278         HE *he = hv_fetch_ent(permittedloops, labelsv, FALSE, 0);
5279         if(SvIV(HeVAL(he)) > 1)
5280             sv_dec(HeVAL(he));
5281         else
5282             hv_delete_ent(permittedloops, labelsv, 0, 0);
5283     }
5284 }
5285 
5286 /*
5287 =for apidoc forbid_outofblock_ops
5288 
5289 Checks an optree that implements a block, to ensure there are no control-flow
5290 ops that attempt to leave the block.  Any C<OP_RETURN> is forbidden, as is any
5291 C<OP_GOTO>. Loops are analysed, so any LOOPEX op (C<OP_NEXT>, C<OP_LAST> or
5292 C<OP_REDO>) that affects a loop that contains it within the block are
5293 permitted, but those that do not are forbidden.
5294 
5295 If any of these forbidden constructions are detected, an exception is thrown
5296 by using the op name and the blockname argument to construct a suitable
5297 message.
5298 
5299 This function alone is not sufficient to ensure the optree does not perform
5300 any of these forbidden activities during runtime, as it might call a different
5301 function that performs a non-local LOOPEX, or a string-eval() that performs a
5302 C<goto>, or various other things. It is intended purely as a compile-time
5303 check for those that could be detected statically. Additional runtime checks
5304 may be required depending on the circumstance it is used for.
5305 
5306 Note currently that I<all> C<OP_GOTO> ops are forbidden, even in cases where
5307 they might otherwise be safe to execute.  This may be permitted in a later
5308 version.
5309 
5310 =cut
5311 */
5312 
5313 void
Perl_forbid_outofblock_ops(pTHX_ OP * o,const char * blockname)5314 Perl_forbid_outofblock_ops(pTHX_ OP *o, const char *blockname)
5315 {
5316     PERL_ARGS_ASSERT_FORBID_OUTOFBLOCK_OPS;
5317 
5318     ENTER;
5319     SAVEVPTR(PL_curcop);
5320 
5321     HV *looplabels = newHV();
5322     SAVEFREESV((SV *)looplabels);
5323 
5324     HV *gotolabels = newHV();
5325     SAVEFREESV((SV *)gotolabels);
5326 
5327     walk_ops_find_labels(aTHX_ o, gotolabels);
5328 
5329     walk_ops_forbid(aTHX_ o, FORBID_LOOPEX_DEFAULT, looplabels, gotolabels, blockname);
5330 
5331     LEAVE;
5332 }
5333 
5334 /* List constructors */
5335 
5336 /*
5337 =for apidoc op_append_elem
5338 
5339 Append an item to the list of ops contained directly within a list-type
5340 op, returning the lengthened list.  C<first> is the list-type op,
5341 and C<last> is the op to append to the list.  C<optype> specifies the
5342 intended opcode for the list.  If C<first> is not already a list of the
5343 right type, it will be upgraded into one.  If either C<first> or C<last>
5344 is null, the other is returned unchanged.
5345 
5346 =cut
5347 */
5348 
5349 OP *
Perl_op_append_elem(pTHX_ I32 type,OP * first,OP * last)5350 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
5351 {
5352     if (!first)
5353         return last;
5354 
5355     if (!last)
5356         return first;
5357 
5358     if (first->op_type != (unsigned)type
5359         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
5360     {
5361         return newLISTOP(type, 0, first, last);
5362     }
5363 
5364     op_sibling_splice(first, cLISTOPx(first)->op_last, 0, last);
5365     first->op_flags |= OPf_KIDS;
5366     return first;
5367 }
5368 
5369 /*
5370 =for apidoc op_append_list
5371 
5372 Concatenate the lists of ops contained directly within two list-type ops,
5373 returning the combined list.  C<first> and C<last> are the list-type ops
5374 to concatenate.  C<optype> specifies the intended opcode for the list.
5375 If either C<first> or C<last> is not already a list of the right type,
5376 it will be upgraded into one.  If either C<first> or C<last> is null,
5377 the other is returned unchanged.
5378 
5379 =cut
5380 */
5381 
5382 OP *
Perl_op_append_list(pTHX_ I32 type,OP * first,OP * last)5383 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
5384 {
5385     if (!first)
5386         return last;
5387 
5388     if (!last)
5389         return first;
5390 
5391     if (first->op_type != (unsigned)type)
5392         return op_prepend_elem(type, first, last);
5393 
5394     if (last->op_type != (unsigned)type)
5395         return op_append_elem(type, first, last);
5396 
5397     OpMORESIB_set(cLISTOPx(first)->op_last, cLISTOPx(last)->op_first);
5398     cLISTOPx(first)->op_last = cLISTOPx(last)->op_last;
5399     OpLASTSIB_set(cLISTOPx(first)->op_last, first);
5400     first->op_flags |= (last->op_flags & OPf_KIDS);
5401 
5402     S_op_destroy(aTHX_ last);
5403 
5404     return first;
5405 }
5406 
5407 /*
5408 =for apidoc op_prepend_elem
5409 
5410 Prepend an item to the list of ops contained directly within a list-type
5411 op, returning the lengthened list.  C<first> is the op to prepend to the
5412 list, and C<last> is the list-type op.  C<optype> specifies the intended
5413 opcode for the list.  If C<last> is not already a list of the right type,
5414 it will be upgraded into one.  If either C<first> or C<last> is null,
5415 the other is returned unchanged.
5416 
5417 =cut
5418 */
5419 
5420 OP *
Perl_op_prepend_elem(pTHX_ I32 type,OP * first,OP * last)5421 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
5422 {
5423     if (!first)
5424         return last;
5425 
5426     if (!last)
5427         return first;
5428 
5429     if (last->op_type == (unsigned)type) {
5430         if (type == OP_LIST) {	/* already a PUSHMARK there */
5431             /* insert 'first' after pushmark */
5432             op_sibling_splice(last, cLISTOPx(last)->op_first, 0, first);
5433             if (!(first->op_flags & OPf_PARENS))
5434                 last->op_flags &= ~OPf_PARENS;
5435         }
5436         else
5437             op_sibling_splice(last, NULL, 0, first);
5438         last->op_flags |= OPf_KIDS;
5439         return last;
5440     }
5441 
5442     return newLISTOP(type, 0, first, last);
5443 }
5444 
5445 /*
5446 =for apidoc op_convert_list
5447 
5448 Converts C<o> into a list op if it is not one already, and then converts it
5449 into the specified C<type>, calling its check function, allocating a target if
5450 it needs one, and folding constants.
5451 
5452 A list-type op is usually constructed one kid at a time via C<newLISTOP>,
5453 C<op_prepend_elem> and C<op_append_elem>.  Then finally it is passed to
5454 C<op_convert_list> to make it the right type.
5455 
5456 =cut
5457 */
5458 
5459 OP *
Perl_op_convert_list(pTHX_ I32 type,I32 flags,OP * o)5460 Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
5461 {
5462     if (type < 0) type = -type, flags |= OPf_SPECIAL;
5463     if (type == OP_RETURN) {
5464         if (FEATURE_MODULE_TRUE_IS_ENABLED)
5465             flags |= OPf_SPECIAL;
5466     }
5467     if (!o || o->op_type != OP_LIST)
5468         o = force_list(o, FALSE);
5469     else
5470     {
5471         o->op_flags &= ~OPf_WANT;
5472         o->op_private &= ~OPpLVAL_INTRO;
5473     }
5474 
5475     if (!(PL_opargs[type] & OA_MARK))
5476         op_null(cLISTOPo->op_first);
5477     else {
5478         OP * const kid2 = OpSIBLING(cLISTOPo->op_first);
5479         if (kid2 && kid2->op_type == OP_COREARGS) {
5480             op_null(cLISTOPo->op_first);
5481             kid2->op_private |= OPpCOREARGS_PUSHMARK;
5482         }
5483     }
5484 
5485     if (type != OP_SPLIT)
5486         /* At this point o is a LISTOP, but OP_SPLIT is a PMOP; let
5487          * ck_split() create a real PMOP and leave the op's type as listop
5488          * for now. Otherwise op_free() etc will crash.
5489          */
5490         OpTYPE_set(o, type);
5491 
5492     o->op_flags |= flags;
5493     if (flags & OPf_FOLDED)
5494         o->op_folded = 1;
5495 
5496     o = CHECKOP(type, o);
5497     if (o->op_type != (unsigned)type)
5498         return o;
5499 
5500     return fold_constants(op_integerize(op_std_init(o)));
5501 }
5502 
5503 /* Constructors */
5504 
5505 
5506 /*
5507 =for apidoc_section $optree_construction
5508 
5509 =for apidoc newNULLLIST
5510 
5511 Constructs, checks, and returns a new C<stub> op, which represents an
5512 empty list expression.
5513 
5514 =cut
5515 */
5516 
5517 OP *
Perl_newNULLLIST(pTHX)5518 Perl_newNULLLIST(pTHX)
5519 {
5520     return newOP(OP_STUB, 0);
5521 }
5522 
5523 /* promote o and any siblings to be a list if its not already; i.e.
5524  *
5525  *  o - A - B
5526  *
5527  * becomes
5528  *
5529  *  list
5530  *    |
5531  *  pushmark - o - A - B
5532  *
5533  * If nullit it true, the list op is nulled.
5534  */
5535 
5536 static OP *
S_force_list(pTHX_ OP * o,bool nullit)5537 S_force_list(pTHX_ OP *o, bool nullit)
5538 {
5539     if (!o || o->op_type != OP_LIST) {
5540         OP *rest = NULL;
5541         if (o) {
5542             /* manually detach any siblings then add them back later */
5543             rest = OpSIBLING(o);
5544             OpLASTSIB_set(o, NULL);
5545         }
5546         o = newLISTOP(OP_LIST, 0, o, NULL);
5547         if (rest)
5548             op_sibling_splice(o, cLISTOPo->op_last, 0, rest);
5549     }
5550     if (nullit)
5551         op_null(o);
5552     return o;
5553 }
5554 
5555 /*
5556 =for apidoc op_force_list
5557 
5558 Promotes o and any siblings to be an C<OP_LIST> if it is not already. If
5559 a new C<OP_LIST> op was created, its first child will be C<OP_PUSHMARK>.
5560 The returned node itself will be nulled, leaving only its children.
5561 
5562 This is often what you want to do before putting the optree into list
5563 context; as
5564 
5565     o = op_contextualize(op_force_list(o), G_LIST);
5566 
5567 =cut
5568 */
5569 
5570 OP *
Perl_op_force_list(pTHX_ OP * o)5571 Perl_op_force_list(pTHX_ OP *o)
5572 {
5573     return force_list(o, TRUE);
5574 }
5575 
5576 /*
5577 =for apidoc newLISTOP
5578 
5579 Constructs, checks, and returns an op of any list type.  C<type> is
5580 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5581 C<OPf_KIDS> will be set automatically if required.  C<first> and C<last>
5582 supply up to two ops to be direct children of the list op; they are
5583 consumed by this function and become part of the constructed op tree.
5584 
5585 For most list operators, the check function expects all the kid ops to be
5586 present already, so calling C<newLISTOP(OP_JOIN, ...)> (e.g.) is not
5587 appropriate.  What you want to do in that case is create an op of type
5588 C<OP_LIST>, append more children to it, and then call L</op_convert_list>.
5589 See L</op_convert_list> for more information.
5590 
5591 =cut
5592 */
5593 
5594 OP *
Perl_newLISTOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)5595 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5596 {
5597     LISTOP *listop;
5598     /* Note that allocating an OP_PUSHMARK can die under Safe.pm if
5599      * pushmark is banned. So do it now while existing ops are in a
5600      * consistent state, in case they suddenly get freed */
5601     OP* const pushop = type == OP_LIST ? newOP(OP_PUSHMARK, 0) : NULL;
5602 
5603     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP
5604         || type == OP_CUSTOM);
5605 
5606     NewOp(1101, listop, 1, LISTOP);
5607     OpTYPE_set(listop, type);
5608     if (first || last)
5609         flags |= OPf_KIDS;
5610     listop->op_flags = (U8)flags;
5611 
5612     if (!last && first)
5613         last = first;
5614     else if (!first && last)
5615         first = last;
5616     else if (first)
5617         OpMORESIB_set(first, last);
5618     listop->op_first = first;
5619     listop->op_last = last;
5620 
5621     if (pushop) {
5622         OpMORESIB_set(pushop, first);
5623         listop->op_first = pushop;
5624         listop->op_flags |= OPf_KIDS;
5625         if (!last)
5626             listop->op_last = pushop;
5627     }
5628     if (listop->op_last)
5629         OpLASTSIB_set(listop->op_last, (OP*)listop);
5630 
5631     return CHECKOP(type, listop);
5632 }
5633 
5634 /*
5635 =for apidoc newOP
5636 
5637 Constructs, checks, and returns an op of any base type (any type that
5638 has no extra fields).  C<type> is the opcode.  C<flags> gives the
5639 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
5640 of C<op_private>.
5641 
5642 =cut
5643 */
5644 
5645 OP *
Perl_newOP(pTHX_ I32 type,I32 flags)5646 Perl_newOP(pTHX_ I32 type, I32 flags)
5647 {
5648     OP *o;
5649 
5650     if (type == -OP_ENTEREVAL) {
5651         type = OP_ENTEREVAL;
5652         flags |= OPpEVAL_BYTES<<8;
5653     }
5654 
5655     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
5656         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5657         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5658         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
5659 
5660     NewOp(1101, o, 1, OP);
5661     OpTYPE_set(o, type);
5662     o->op_flags = (U8)flags;
5663 
5664     o->op_next = o;
5665     o->op_private = (U8)(0 | (flags >> 8));
5666     if (PL_opargs[type] & OA_RETSCALAR)
5667         scalar(o);
5668     if (PL_opargs[type] & OA_TARGET)
5669         o->op_targ = pad_alloc(type, SVs_PADTMP);
5670     return CHECKOP(type, o);
5671 }
5672 
5673 /*
5674 =for apidoc newUNOP
5675 
5676 Constructs, checks, and returns an op of any unary type.  C<type> is
5677 the opcode.  C<flags> gives the eight bits of C<op_flags>, except that
5678 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
5679 bits, the eight bits of C<op_private>, except that the bit with value 1
5680 is automatically set.  C<first> supplies an optional op to be the direct
5681 child of the unary op; it is consumed by this function and become part
5682 of the constructed op tree.
5683 
5684 =for apidoc Amnh||OPf_KIDS
5685 
5686 =cut
5687 */
5688 
5689 OP *
Perl_newUNOP(pTHX_ I32 type,I32 flags,OP * first)5690 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
5691 {
5692     UNOP *unop;
5693 
5694     if (type == -OP_ENTEREVAL) {
5695         type = OP_ENTEREVAL;
5696         flags |= OPpEVAL_BYTES<<8;
5697     }
5698 
5699     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
5700         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
5701         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
5702         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
5703         || type == OP_SASSIGN
5704         || type == OP_ENTERTRY
5705         || type == OP_ENTERTRYCATCH
5706         || type == OP_CUSTOM
5707         || type == OP_NULL );
5708 
5709     if (!first)
5710         first = newOP(OP_STUB, 0);
5711     if (PL_opargs[type] & OA_MARK)
5712         first = op_force_list(first);
5713 
5714     NewOp(1101, unop, 1, UNOP);
5715     OpTYPE_set(unop, type);
5716     unop->op_first = first;
5717     unop->op_flags = (U8)(flags | OPf_KIDS);
5718     unop->op_private = (U8)(1 | (flags >> 8));
5719 
5720     if (!OpHAS_SIBLING(first)) /* true unless weird syntax error */
5721         OpLASTSIB_set(first, (OP*)unop);
5722 
5723     unop = (UNOP*) CHECKOP(type, unop);
5724     if (unop->op_next)
5725         return (OP*)unop;
5726 
5727     return fold_constants(op_integerize(op_std_init((OP *) unop)));
5728 }
5729 
5730 /*
5731 =for apidoc newUNOP_AUX
5732 
5733 Similar to C<newUNOP>, but creates an C<UNOP_AUX> struct instead, with C<op_aux>
5734 initialised to C<aux>
5735 
5736 =cut
5737 */
5738 
5739 OP *
Perl_newUNOP_AUX(pTHX_ I32 type,I32 flags,OP * first,UNOP_AUX_item * aux)5740 Perl_newUNOP_AUX(pTHX_ I32 type, I32 flags, OP *first, UNOP_AUX_item *aux)
5741 {
5742     UNOP_AUX *unop;
5743 
5744     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP_AUX
5745         || type == OP_CUSTOM);
5746 
5747     NewOp(1101, unop, 1, UNOP_AUX);
5748     unop->op_type = (OPCODE)type;
5749     unop->op_ppaddr = PL_ppaddr[type];
5750     unop->op_first = first;
5751     unop->op_flags = (U8)(flags | (first ? OPf_KIDS : 0));
5752     unop->op_private = (U8)((first ? 1 : 0) | (flags >> 8));
5753     unop->op_aux = aux;
5754 
5755     if (first && !OpHAS_SIBLING(first)) /* true unless weird syntax error */
5756         OpLASTSIB_set(first, (OP*)unop);
5757 
5758     unop = (UNOP_AUX*) CHECKOP(type, unop);
5759 
5760     return op_std_init((OP *) unop);
5761 }
5762 
5763 /*
5764 =for apidoc newMETHOP
5765 
5766 Constructs, checks, and returns an op of method type with a method name
5767 evaluated at runtime.  C<type> is the opcode.  C<flags> gives the eight
5768 bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
5769 and, shifted up eight bits, the eight bits of C<op_private>, except that
5770 the bit with value 1 is automatically set.  C<dynamic_meth> supplies an
5771 op which evaluates method name; it is consumed by this function and
5772 become part of the constructed op tree.
5773 Supported optypes: C<OP_METHOD>.
5774 
5775 =cut
5776 */
5777 
5778 static OP*
S_newMETHOP_internal(pTHX_ I32 type,I32 flags,OP * dynamic_meth,SV * const_meth)5779 S_newMETHOP_internal(pTHX_ I32 type, I32 flags, OP* dynamic_meth, SV* const_meth) {
5780     METHOP *methop;
5781 
5782     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_METHOP
5783         || type == OP_CUSTOM);
5784 
5785     NewOp(1101, methop, 1, METHOP);
5786     if (dynamic_meth) {
5787         if (PL_opargs[type] & OA_MARK) dynamic_meth = op_force_list(dynamic_meth);
5788         methop->op_flags = (U8)(flags | OPf_KIDS);
5789         methop->op_u.op_first = dynamic_meth;
5790         methop->op_private = (U8)(1 | (flags >> 8));
5791 
5792         if (!OpHAS_SIBLING(dynamic_meth))
5793             OpLASTSIB_set(dynamic_meth, (OP*)methop);
5794     }
5795     else {
5796         assert(const_meth);
5797         methop->op_flags = (U8)(flags & ~OPf_KIDS);
5798         methop->op_u.op_meth_sv = const_meth;
5799         methop->op_private = (U8)(0 | (flags >> 8));
5800         methop->op_next = (OP*)methop;
5801     }
5802 
5803 #ifdef USE_ITHREADS
5804     methop->op_rclass_targ = 0;
5805 #else
5806     methop->op_rclass_sv = NULL;
5807 #endif
5808 
5809     OpTYPE_set(methop, type);
5810     return CHECKOP(type, methop);
5811 }
5812 
5813 OP *
Perl_newMETHOP(pTHX_ I32 type,I32 flags,OP * dynamic_meth)5814 Perl_newMETHOP (pTHX_ I32 type, I32 flags, OP* dynamic_meth) {
5815     PERL_ARGS_ASSERT_NEWMETHOP;
5816     return newMETHOP_internal(type, flags, dynamic_meth, NULL);
5817 }
5818 
5819 /*
5820 =for apidoc newMETHOP_named
5821 
5822 Constructs, checks, and returns an op of method type with a constant
5823 method name.  C<type> is the opcode.  C<flags> gives the eight bits of
5824 C<op_flags>, and, shifted up eight bits, the eight bits of
5825 C<op_private>.  C<const_meth> supplies a constant method name;
5826 it must be a shared COW string.
5827 Supported optypes: C<OP_METHOD_NAMED>.
5828 
5829 =cut
5830 */
5831 
5832 OP *
Perl_newMETHOP_named(pTHX_ I32 type,I32 flags,SV * const_meth)5833 Perl_newMETHOP_named (pTHX_ I32 type, I32 flags, SV* const_meth) {
5834     PERL_ARGS_ASSERT_NEWMETHOP_NAMED;
5835     return newMETHOP_internal(type, flags, NULL, const_meth);
5836 }
5837 
5838 /*
5839 =for apidoc newBINOP
5840 
5841 Constructs, checks, and returns an op of any binary type.  C<type>
5842 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
5843 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
5844 the eight bits of C<op_private>, except that the bit with value 1 or
5845 2 is automatically set as required.  C<first> and C<last> supply up to
5846 two ops to be the direct children of the binary op; they are consumed
5847 by this function and become part of the constructed op tree.
5848 
5849 =cut
5850 */
5851 
5852 OP *
Perl_newBINOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)5853 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
5854 {
5855     BINOP *binop;
5856 
5857     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
5858         || type == OP_NULL || type == OP_CUSTOM);
5859 
5860     NewOp(1101, binop, 1, BINOP);
5861 
5862     if (!first)
5863         first = newOP(OP_NULL, 0);
5864 
5865     OpTYPE_set(binop, type);
5866     binop->op_first = first;
5867     binop->op_flags = (U8)(flags | OPf_KIDS);
5868     if (!last) {
5869         last = first;
5870         binop->op_private = (U8)(1 | (flags >> 8));
5871     }
5872     else {
5873         binop->op_private = (U8)(2 | (flags >> 8));
5874         OpMORESIB_set(first, last);
5875     }
5876 
5877     if (!OpHAS_SIBLING(last)) /* true unless weird syntax error */
5878         OpLASTSIB_set(last, (OP*)binop);
5879 
5880     binop->op_last = OpSIBLING(binop->op_first);
5881     if (binop->op_last)
5882         OpLASTSIB_set(binop->op_last, (OP*)binop);
5883 
5884     binop = (BINOP*) CHECKOP(type, binop);
5885     if (binop->op_next || binop->op_type != (OPCODE)type)
5886         return (OP*)binop;
5887 
5888     return fold_constants(op_integerize(op_std_init((OP *)binop)));
5889 }
5890 
5891 void
Perl_invmap_dump(pTHX_ SV * invlist,UV * map)5892 Perl_invmap_dump(pTHX_ SV* invlist, UV *map)
5893 {
5894     const char indent[] = "    ";
5895 
5896     UV len = _invlist_len(invlist);
5897     UV * array = invlist_array(invlist);
5898     UV i;
5899 
5900     PERL_ARGS_ASSERT_INVMAP_DUMP;
5901 
5902     for (i = 0; i < len; i++) {
5903         UV start = array[i];
5904         UV end   = (i + 1 < len) ? array[i+1] - 1 : IV_MAX;
5905 
5906         PerlIO_printf(Perl_debug_log, "%s[%" UVuf "] 0x%04" UVXf, indent, i, start);
5907         if (end == IV_MAX) {
5908             PerlIO_printf(Perl_debug_log, " .. INFTY");
5909         }
5910         else if (end != start) {
5911             PerlIO_printf(Perl_debug_log, " .. 0x%04" UVXf, end);
5912         }
5913         else {
5914             PerlIO_printf(Perl_debug_log, "            ");
5915         }
5916 
5917         PerlIO_printf(Perl_debug_log, "\t");
5918 
5919         if (map[i] == TR_UNLISTED) {
5920             PerlIO_printf(Perl_debug_log, "TR_UNLISTED\n");
5921         }
5922         else if (map[i] == TR_SPECIAL_HANDLING) {
5923             PerlIO_printf(Perl_debug_log, "TR_SPECIAL_HANDLING\n");
5924         }
5925         else {
5926             PerlIO_printf(Perl_debug_log, "0x%04" UVXf "\n", map[i]);
5927         }
5928     }
5929 }
5930 
5931 /* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
5932  * containing the search and replacement strings, assemble into
5933  * a translation table attached as o->op_pv.
5934  * Free expr and repl.
5935  * It expects the toker to have already set the
5936  *   OPpTRANS_COMPLEMENT
5937  *   OPpTRANS_SQUASH
5938  *   OPpTRANS_DELETE
5939  * flags as appropriate; this function may add
5940  *   OPpTRANS_USE_SVOP
5941  *   OPpTRANS_CAN_FORCE_UTF8
5942  *   OPpTRANS_IDENTICAL
5943  *   OPpTRANS_GROWS
5944  * flags
5945  */
5946 
5947 static OP *
S_pmtrans(pTHX_ OP * o,OP * expr,OP * repl)5948 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
5949 {
5950     /* This function compiles a tr///, from data gathered from toke.c, into a
5951      * form suitable for use by do_trans() in doop.c at runtime.
5952      *
5953      * It first normalizes the data, while discarding extraneous inputs; then
5954      * writes out the compiled data.  The normalization allows for complete
5955      * analysis, and avoids some false negatives and positives earlier versions
5956      * of this code had.
5957      *
5958      * The normalization form is an inversion map (described below in detail).
5959      * This is essentially the compiled form for tr///'s that require UTF-8,
5960      * and its easy to use it to write the 257-byte table for tr///'s that
5961      * don't need UTF-8.  That table is identical to what's been in use for
5962      * many perl versions, except that it doesn't handle some edge cases that
5963      * it used to, involving code points above 255.  The UTF-8 form now handles
5964      * these.  (This could be changed with extra coding should it shown to be
5965      * desirable.)
5966      *
5967      * If the complement (/c) option is specified, the lhs string (tstr) is
5968      * parsed into an inversion list.  Complementing these is trivial.  Then a
5969      * complemented tstr is built from that, and used thenceforth.  This hides
5970      * the fact that it was complemented from almost all successive code.
5971      *
5972      * One of the important characteristics to know about the input is whether
5973      * the transliteration may be done in place, or does a temporary need to be
5974      * allocated, then copied.  If the replacement for every character in every
5975      * possible string takes up no more bytes than the character it
5976      * replaces, then it can be edited in place.  Otherwise the replacement
5977      * could overwrite a byte we are about to read, depending on the strings
5978      * being processed.  The comments and variable names here refer to this as
5979      * "growing".  Some inputs won't grow, and might even shrink under /d, but
5980      * some inputs could grow, so we have to assume any given one might grow.
5981      * On very long inputs, the temporary could eat up a lot of memory, so we
5982      * want to avoid it if possible.  For non-UTF-8 inputs, everything is
5983      * single-byte, so can be edited in place, unless there is something in the
5984      * pattern that could force it into UTF-8.  The inversion map makes it
5985      * feasible to determine this.  Previous versions of this code pretty much
5986      * punted on determining if UTF-8 could be edited in place.  Now, this code
5987      * is rigorous in making that determination.
5988      *
5989      * Another characteristic we need to know is whether the lhs and rhs are
5990      * identical.  If so, and no other flags are present, the only effect of
5991      * the tr/// is to count the characters present in the input that are
5992      * mentioned in the lhs string.  The implementation of that is easier and
5993      * runs faster than the more general case.  Normalizing here allows for
5994      * accurate determination of this.  Previously there were false negatives
5995      * possible.
5996      *
5997      * Instead of 'transliterated', the comments here use 'unmapped' for the
5998      * characters that are left unchanged by the operation; otherwise they are
5999      * 'mapped'
6000      *
6001      * The lhs of the tr/// is here referred to as the t side.
6002      * The rhs of the tr/// is here referred to as the r side.
6003      */
6004 
6005     SV * const tstr = cSVOPx(expr)->op_sv;
6006     SV * const rstr = cSVOPx(repl)->op_sv;
6007     STRLEN tlen;
6008     STRLEN rlen;
6009     const U8 * t0 = (U8*)SvPV_const(tstr, tlen);
6010     const U8 * r0 = (U8*)SvPV_const(rstr, rlen);
6011     const U8 * t = t0;
6012     const U8 * r = r0;
6013     UV t_count = 0, r_count = 0;  /* Number of characters in search and
6014                                          replacement lists */
6015 
6016     /* khw thinks some of the private flags for this op are quaintly named.
6017      * OPpTRANS_GROWS for example is TRUE if the replacement for some lhs
6018      * character when represented in UTF-8 is longer than the original
6019      * character's UTF-8 representation */
6020     const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
6021     const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
6022     const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
6023 
6024     /* Set to true if there is some character < 256 in the lhs that maps to
6025      * above 255.  If so, a non-UTF-8 match string can be forced into being in
6026      * UTF-8 by a tr/// operation. */
6027     bool can_force_utf8 = FALSE;
6028 
6029     /* What is the maximum expansion factor in UTF-8 transliterations.  If a
6030      * 2-byte UTF-8 encoded character is to be replaced by a 3-byte one, its
6031      * expansion factor is 1.5.  This number is used at runtime to calculate
6032      * how much space to allocate for non-inplace transliterations.  Without
6033      * this number, the worst case is 14, which is extremely unlikely to happen
6034      * in real life, and could require significant memory overhead. */
6035     NV max_expansion = 1.;
6036 
6037     UV t_range_count, r_range_count, min_range_count;
6038     UV* t_array;
6039     SV* t_invlist;
6040     UV* r_map;
6041     UV r_cp = 0, t_cp = 0;
6042     UV t_cp_end = (UV) -1;
6043     UV r_cp_end;
6044     Size_t len;
6045     AV* invmap;
6046     UV final_map = TR_UNLISTED;    /* The final character in the replacement
6047                                       list, updated as we go along.  Initialize
6048                                       to something illegal */
6049 
6050     bool rstr_utf8 = cBOOL(SvUTF8(rstr));
6051     bool tstr_utf8 = cBOOL(SvUTF8(tstr));
6052 
6053     const U8* tend = t + tlen;
6054     const U8* rend = r + rlen;
6055 
6056     SV * inverted_tstr = NULL;
6057 
6058     Size_t i;
6059     unsigned int pass2;
6060 
6061     /* This routine implements detection of a transliteration having a longer
6062      * UTF-8 representation than its source, by partitioning all the possible
6063      * code points of the platform into equivalence classes of the same UTF-8
6064      * byte length in the first pass.  As it constructs the mappings, it carves
6065      * these up into smaller chunks, but doesn't merge any together.  This
6066      * makes it easy to find the instances it's looking for.  A second pass is
6067      * done after this has been determined which merges things together to
6068      * shrink the table for runtime.  The table below is used for both ASCII
6069      * and EBCDIC platforms.  On EBCDIC, the byte length is not monotonically
6070      * increasing for code points below 256.  To correct for that, the macro
6071      * CP_ADJUST defined below converts those code points to ASCII in the first
6072      * pass, and we use the ASCII partition values.  That works because the
6073      * growth factor will be unaffected, which is all that is calculated during
6074      * the first pass. */
6075     UV PL_partition_by_byte_length[] = {
6076         0,
6077         0x80,   /* Below this is 1 byte representations */
6078         (32 * (1UL << (    UTF_ACCUMULATION_SHIFT))),   /* 2 bytes below this */
6079         (16 * (1UL << (2 * UTF_ACCUMULATION_SHIFT))),   /* 3 bytes below this */
6080         ( 8 * (1UL << (3 * UTF_ACCUMULATION_SHIFT))),   /* 4 bytes below this */
6081         ( 4 * (1UL << (4 * UTF_ACCUMULATION_SHIFT))),   /* 5 bytes below this */
6082         ( 2 * (1UL << (5 * UTF_ACCUMULATION_SHIFT)))    /* 6 bytes below this */
6083 
6084 #  ifdef UV_IS_QUAD
6085                                                     ,
6086         ( ((UV) 1U << (6 * UTF_ACCUMULATION_SHIFT)))    /* 7 bytes below this */
6087 #  endif
6088 
6089     };
6090 
6091     PERL_ARGS_ASSERT_PMTRANS;
6092 
6093     PL_hints |= HINT_BLOCK_SCOPE;
6094 
6095     /* If /c, the search list is sorted and complemented.  This is now done by
6096      * creating an inversion list from it, and then trivially inverting that.
6097      * The previous implementation used qsort, but creating the list
6098      * automatically keeps it sorted as we go along */
6099     if (complement) {
6100         UV start, end;
6101         SV * inverted_tlist = _new_invlist(tlen);
6102         Size_t temp_len;
6103 
6104         DEBUG_y(PerlIO_printf(Perl_debug_log,
6105                     "%s: %d: tstr before inversion=\n%s\n",
6106                     __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
6107 
6108         while (t < tend) {
6109 
6110             /* Non-utf8 strings don't have ranges, so each character is listed
6111              * out */
6112             if (! tstr_utf8) {
6113                 inverted_tlist = add_cp_to_invlist(inverted_tlist, *t);
6114                 t++;
6115             }
6116             else {  /* But UTF-8 strings have been parsed in toke.c to have
6117                  * ranges if appropriate. */
6118                 UV t_cp;
6119                 Size_t t_char_len;
6120 
6121                 /* Get the first character */
6122                 t_cp = valid_utf8_to_uvchr(t, &t_char_len);
6123                 t += t_char_len;
6124 
6125                 /* If the next byte indicates that this wasn't the first
6126                  * element of a range, the range is just this one */
6127                 if (t >= tend || *t != RANGE_INDICATOR) {
6128                     inverted_tlist = add_cp_to_invlist(inverted_tlist, t_cp);
6129                 }
6130                 else { /* Otherwise, ignore the indicator byte, and get the
6131                           final element, and add the whole range */
6132                     t++;
6133                     t_cp_end = valid_utf8_to_uvchr(t, &t_char_len);
6134                     t += t_char_len;
6135 
6136                     inverted_tlist = _add_range_to_invlist(inverted_tlist,
6137                                                       t_cp, t_cp_end);
6138                 }
6139             }
6140         } /* End of parse through tstr */
6141 
6142         /* The inversion list is done; now invert it */
6143         _invlist_invert(inverted_tlist);
6144 
6145         /* Now go through the inverted list and create a new tstr for the rest
6146          * of the routine to use.  Since the UTF-8 version can have ranges, and
6147          * can be much more compact than the non-UTF-8 version, we create the
6148          * string in UTF-8 even if not necessary.  (This is just an intermediate
6149          * value that gets thrown away anyway.) */
6150         invlist_iterinit(inverted_tlist);
6151         inverted_tstr = newSVpvs("");
6152         while (invlist_iternext(inverted_tlist, &start, &end)) {
6153             U8 temp[UTF8_MAXBYTES];
6154             U8 * temp_end_pos;
6155 
6156             /* IV_MAX keeps things from going out of bounds */
6157             start = MIN(IV_MAX, start);
6158             end   = MIN(IV_MAX, end);
6159 
6160             temp_end_pos = uvchr_to_utf8(temp, start);
6161             sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
6162 
6163             if (start != end) {
6164                 Perl_sv_catpvf(aTHX_ inverted_tstr, "%c", RANGE_INDICATOR);
6165                 temp_end_pos = uvchr_to_utf8(temp, end);
6166                 sv_catpvn(inverted_tstr, (char *) temp, temp_end_pos - temp);
6167             }
6168         }
6169 
6170         /* Set up so the remainder of the routine uses this complement, instead
6171          * of the actual input */
6172         t0 = t = (U8*)SvPV_const(inverted_tstr, temp_len);
6173         tend = t0 + temp_len;
6174         tstr_utf8 = TRUE;
6175 
6176         SvREFCNT_dec_NN(inverted_tlist);
6177     }
6178 
6179     /* For non-/d, an empty rhs means to use the lhs */
6180     if (rlen == 0 && ! del) {
6181         r0 = t0;
6182         rend = tend;
6183         rstr_utf8  = tstr_utf8;
6184     }
6185 
6186     t_invlist = _new_invlist(1);
6187 
6188     /* Initialize to a single range */
6189     t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
6190 
6191     /* Below, we parse the (potentially adjusted) input, creating the inversion
6192      * map.  This is done in two passes.  The first pass is just to determine
6193      * if the transliteration can be done in-place.  It can be done in place if
6194      * no possible inputs result in the replacement taking up more bytes than
6195      * the input.  To figure that out, in the first pass we start with all the
6196      * possible code points partitioned into ranges so that every code point in
6197      * a range occupies the same number of UTF-8 bytes as every other code
6198      * point in the range.  Constructing the inversion map doesn't merge ranges
6199      * together, but can split them into multiple ones.  Given the starting
6200      * partition, the ending state will also have the same characteristic,
6201      * namely that each code point in each partition requires the same number
6202      * of UTF-8 bytes to represent as every other code point in the same
6203      * partition.
6204      *
6205      * This partitioning has been pre-compiled.  Copy it to initialize */
6206     len = C_ARRAY_LENGTH(PL_partition_by_byte_length);
6207     invlist_extend(t_invlist, len);
6208     t_array = invlist_array(t_invlist);
6209     Copy(PL_partition_by_byte_length, t_array, len, UV);
6210     invlist_set_len(t_invlist, len, *(get_invlist_offset_addr(t_invlist)));
6211     Newx(r_map, len + 1, UV);
6212 
6213     /* The inversion map the first pass creates could be used as-is, but
6214      * generally would be larger and slower to run than the output of the
6215      * second pass.  */
6216 
6217     for (pass2 = 0; pass2 < 2; pass2++) {
6218         if (pass2) {
6219             /* In the second pass, we start with a single range */
6220             t_invlist = _add_range_to_invlist(t_invlist, 0, UV_MAX);
6221             len = 1;
6222             t_array = invlist_array(t_invlist);
6223         }
6224 
6225 /* As noted earlier, we convert EBCDIC code points to Unicode in the first pass
6226  * so as to get the well-behaved length 1 vs length 2 boundary.  Only code
6227  * points below 256 differ between the two character sets in this regard.  For
6228  * these, we also can't have any ranges, as they have to be individually
6229  * converted. */
6230 #ifdef EBCDIC
6231 #  define CP_ADJUST(x)          ((pass2) ? (x) : NATIVE_TO_UNI(x))
6232 #  define FORCE_RANGE_LEN_1(x)  ((pass2) ? 0 : ((x) < 256))
6233 #  define CP_SKIP(x)            ((pass2) ? UVCHR_SKIP(x) : OFFUNISKIP(x))
6234 #else
6235 #  define CP_ADJUST(x)          (x)
6236 #  define FORCE_RANGE_LEN_1(x)  0
6237 #  define CP_SKIP(x)            UVCHR_SKIP(x)
6238 #endif
6239 
6240         /* And the mapping of each of the ranges is initialized.  Initially,
6241          * everything is TR_UNLISTED. */
6242         for (i = 0; i < len; i++) {
6243             r_map[i] = TR_UNLISTED;
6244         }
6245 
6246         t = t0;
6247         t_count = 0;
6248         r = r0;
6249         r_count = 0;
6250         t_range_count = r_range_count = 0;
6251 
6252         DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d:\ntstr=%s\n",
6253                     __FILE__, __LINE__, _byte_dump_string(t, tend - t, 0)));
6254         DEBUG_y(PerlIO_printf(Perl_debug_log, "rstr=%s\n",
6255                                         _byte_dump_string(r, rend - r, 0)));
6256         DEBUG_y(PerlIO_printf(Perl_debug_log, "/c=%d; /s=%d; /d=%d\n",
6257                                                   complement, squash, del));
6258         DEBUG_y(invmap_dump(t_invlist, r_map));
6259 
6260         /* Now go through the search list constructing an inversion map.  The
6261          * input is not necessarily in any particular order.  Making it an
6262          * inversion map orders it, potentially simplifying, and makes it easy
6263          * to deal with at run time.  This is the only place in core that
6264          * generates an inversion map; if others were introduced, it might be
6265          * better to create general purpose routines to handle them.
6266          * (Inversion maps are created in perl in other places.)
6267          *
6268          * An inversion map consists of two parallel arrays.  One is
6269          * essentially an inversion list: an ordered list of code points such
6270          * that each element gives the first code point of a range of
6271          * consecutive code points that map to the element in the other array
6272          * that has the same index as this one (in other words, the
6273          * corresponding element).  Thus the range extends up to (but not
6274          * including) the code point given by the next higher element.  In a
6275          * true inversion map, the corresponding element in the other array
6276          * gives the mapping of the first code point in the range, with the
6277          * understanding that the next higher code point in the inversion
6278          * list's range will map to the next higher code point in the map.
6279          *
6280          * So if at element [i], let's say we have:
6281          *
6282          *     t_invlist  r_map
6283          * [i]    A         a
6284          *
6285          * This means that A => a, B => b, C => c....  Let's say that the
6286          * situation is such that:
6287          *
6288          * [i+1]  L        -1
6289          *
6290          * This means the sequence that started at [i] stops at K => k.  This
6291          * illustrates that you need to look at the next element to find where
6292          * a sequence stops.  Except, the highest element in the inversion list
6293          * begins a range that is understood to extend to the platform's
6294          * infinity.
6295          *
6296          * This routine modifies traditional inversion maps to reserve two
6297          * mappings:
6298          *
6299          *  TR_UNLISTED (or -1) indicates that no code point in the range
6300          *      is listed in the tr/// searchlist.  At runtime, these are
6301          *      always passed through unchanged.  In the inversion map, all
6302          *      points in the range are mapped to -1, instead of increasing,
6303          *      like the 'L' in the example above.
6304          *
6305          *      We start the parse with every code point mapped to this, and as
6306          *      we parse and find ones that are listed in the search list, we
6307          *      carve out ranges as we go along that override that.
6308          *
6309          *  TR_SPECIAL_HANDLING (or -2) indicates that every code point in the
6310          *      range needs special handling.  Again, all code points in the
6311          *      range are mapped to -2, instead of increasing.
6312          *
6313          *      Under /d this value means the code point should be deleted from
6314          *      the transliteration when encountered.
6315          *
6316          *      Otherwise, it marks that every code point in the range is to
6317          *      map to the final character in the replacement list.  This
6318          *      happens only when the replacement list is shorter than the
6319          *      search one, so there are things in the search list that have no
6320          *      correspondence in the replacement list.  For example, in
6321          *      tr/a-z/A/, 'A' is the final value, and the inversion map
6322          *      generated for this would be like this:
6323          *          \0  =>  -1
6324          *          a   =>   A
6325          *          b-z =>  -2
6326          *          z+1 =>  -1
6327          *      'A' appears once, then the remainder of the range maps to -2.
6328          *      The use of -2 isn't strictly necessary, as an inversion map is
6329          *      capable of representing this situation, but not nearly so
6330          *      compactly, and this is actually quite commonly encountered.
6331          *      Indeed, the original design of this code used a full inversion
6332          *      map for this.  But things like
6333          *          tr/\0-\x{FFFF}/A/
6334          *      generated huge data structures, slowly, and the execution was
6335          *      also slow.  So the current scheme was implemented.
6336          *
6337          *  So, if the next element in our example is:
6338          *
6339          * [i+2]  Q        q
6340          *
6341          * Then all of L, M, N, O, and P map to TR_UNLISTED.  If the next
6342          * elements are
6343          *
6344          * [i+3]  R        z
6345          * [i+4]  S       TR_UNLISTED
6346          *
6347          * Then Q => q; R => z; and S => TR_UNLISTED.  If [i+4] (the 'S') is
6348          * the final element in the arrays, every code point from S to infinity
6349          * maps to TR_UNLISTED.
6350          *
6351          */
6352                            /* Finish up range started in what otherwise would
6353                             * have been the final iteration */
6354         while (t < tend || t_range_count > 0) {
6355             bool adjacent_to_range_above = FALSE;
6356             bool adjacent_to_range_below = FALSE;
6357 
6358             bool merge_with_range_above = FALSE;
6359             bool merge_with_range_below = FALSE;
6360 
6361             UV span, invmap_range_length_remaining;
6362             SSize_t j;
6363             Size_t i;
6364 
6365             /* If we are in the middle of processing a range in the 'target'
6366              * side, the previous iteration has set us up.  Otherwise, look at
6367              * the next character in the search list */
6368             if (t_range_count <= 0) {
6369                 if (! tstr_utf8) {
6370 
6371                     /* Here, not in the middle of a range, and not UTF-8.  The
6372                      * next code point is the single byte where we're at */
6373                     t_cp = CP_ADJUST(*t);
6374                     t_range_count = 1;
6375                     t++;
6376                 }
6377                 else {
6378                     Size_t t_char_len;
6379 
6380                     /* Here, not in the middle of a range, and is UTF-8.  The
6381                      * next code point is the next UTF-8 char in the input.  We
6382                      * know the input is valid, because the toker constructed
6383                      * it */
6384                     t_cp = CP_ADJUST(valid_utf8_to_uvchr(t, &t_char_len));
6385                     t += t_char_len;
6386 
6387                     /* UTF-8 strings (only) have been parsed in toke.c to have
6388                      * ranges.  See if the next byte indicates that this was
6389                      * the first element of a range.  If so, get the final
6390                      * element and calculate the range size.  If not, the range
6391                      * size is 1 */
6392                     if (   t < tend && *t == RANGE_INDICATOR
6393                         && ! FORCE_RANGE_LEN_1(t_cp))
6394                     {
6395                         t++;
6396                         t_range_count = valid_utf8_to_uvchr(t, &t_char_len)
6397                                       - t_cp + 1;
6398                         t += t_char_len;
6399                     }
6400                     else {
6401                         t_range_count = 1;
6402                     }
6403                 }
6404 
6405                 /* Count the total number of listed code points * */
6406                 t_count += t_range_count;
6407             }
6408 
6409             /* Similarly, get the next character in the replacement list */
6410             if (r_range_count <= 0) {
6411                 if (r >= rend) {
6412 
6413                     /* But if we've exhausted the rhs, there is nothing to map
6414                      * to, except the special handling one, and we make the
6415                      * range the same size as the lhs one. */
6416                     r_cp = TR_SPECIAL_HANDLING;
6417                     r_range_count = t_range_count;
6418 
6419                     if (! del) {
6420                         DEBUG_yv(PerlIO_printf(Perl_debug_log,
6421                                         "final_map =%" UVXf "\n", final_map));
6422                     }
6423                 }
6424                 else {
6425                     if (! rstr_utf8) {
6426                         r_cp = CP_ADJUST(*r);
6427                         r_range_count = 1;
6428                         r++;
6429                     }
6430                     else {
6431                         Size_t r_char_len;
6432 
6433                         r_cp = CP_ADJUST(valid_utf8_to_uvchr(r, &r_char_len));
6434                         r += r_char_len;
6435                         if (   r < rend && *r == RANGE_INDICATOR
6436                             && ! FORCE_RANGE_LEN_1(r_cp))
6437                         {
6438                             r++;
6439                             r_range_count = valid_utf8_to_uvchr(r,
6440                                                     &r_char_len) - r_cp + 1;
6441                             r += r_char_len;
6442                         }
6443                         else {
6444                             r_range_count = 1;
6445                         }
6446                     }
6447 
6448                     if (r_cp == TR_SPECIAL_HANDLING) {
6449                         r_range_count = t_range_count;
6450                     }
6451 
6452                     /* This is the final character so far */
6453                     final_map = r_cp + r_range_count - 1;
6454 
6455                     r_count += r_range_count;
6456                 }
6457             }
6458 
6459             /* Here, we have the next things ready in both sides.  They are
6460              * potentially ranges.  We try to process as big a chunk as
6461              * possible at once, but the lhs and rhs must be synchronized, so
6462              * things like tr/A-Z/a-ij-z/ will need to be processed in 2 chunks
6463              * */
6464             min_range_count = MIN(t_range_count, r_range_count);
6465 
6466             /* Search the inversion list for the entry that contains the input
6467              * code point <cp>.  The inversion map was initialized to cover the
6468              * entire range of possible inputs, so this should not fail.  So
6469              * the return value is the index into the list's array of the range
6470              * that contains <cp>, that is, 'i' such that array[i] <= cp <
6471              * array[i+1] */
6472             j = _invlist_search(t_invlist, t_cp);
6473             assert(j >= 0);
6474             i = j;
6475 
6476             /* Here, the data structure might look like:
6477              *
6478              * index    t   r     Meaning
6479              * [i-1]    J   j   # J-L => j-l
6480              * [i]      M  -1   # M => default; as do N, O, P, Q
6481              * [i+1]    R   x   # R => x, S => x+1, T => x+2
6482              * [i+2]    U   y   # U => y, V => y+1, ...
6483              * ...
6484              * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6485              *
6486              * where 'x' and 'y' above are not to be taken literally.
6487              *
6488              * The maximum chunk we can handle in this loop iteration, is the
6489              * smallest of the three components: the lhs 't_', the rhs 'r_',
6490              * and the remainder of the range in element [i].  (In pass 1, that
6491              * range will have everything in it be of the same class; we can't
6492              * cross into another class.)  'min_range_count' already contains
6493              * the smallest of the first two values.  The final one is
6494              * irrelevant if the map is to the special indicator */
6495 
6496             invmap_range_length_remaining = (i + 1 < len)
6497                                             ? t_array[i+1] - t_cp
6498                                             : IV_MAX - t_cp;
6499             span = MAX(1, MIN(min_range_count, invmap_range_length_remaining));
6500 
6501             /* The end point of this chunk is where we are, plus the span, but
6502              * never larger than the platform's infinity */
6503             t_cp_end = MIN(IV_MAX, t_cp + span - 1);
6504 
6505             if (r_cp == TR_SPECIAL_HANDLING) {
6506 
6507                 /* If unmatched lhs code points map to the final map, use that
6508                  * value.  This being set to TR_SPECIAL_HANDLING indicates that
6509                  * we don't have a final map: unmatched lhs code points are
6510                  * simply deleted */
6511                 r_cp_end = (del) ? TR_SPECIAL_HANDLING : final_map;
6512             }
6513             else {
6514                 r_cp_end = MIN(IV_MAX, r_cp + span - 1);
6515 
6516                 /* If something on the lhs is below 256, and something on the
6517                  * rhs is above, there is a potential mapping here across that
6518                  * boundary.  Indeed the only way there isn't is if both sides
6519                  * start at the same point.  That means they both cross at the
6520                  * same time.  But otherwise one crosses before the other */
6521                 if (t_cp < 256 && r_cp_end > 255 && r_cp != t_cp) {
6522                     can_force_utf8 = TRUE;
6523                 }
6524             }
6525 
6526             /* If a character appears in the search list more than once, the
6527              * 2nd and succeeding occurrences are ignored, so only do this
6528              * range if haven't already processed this character.  (The range
6529              * has been set up so that all members in it will be of the same
6530              * ilk) */
6531             if (r_map[i] == TR_UNLISTED) {
6532                 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6533                     "Processing %" UVxf "-%" UVxf " => %" UVxf "-%" UVxf "\n",
6534                     t_cp, t_cp_end, r_cp, r_cp_end));
6535 
6536                 /* This is the first definition for this chunk, hence is valid
6537                  * and needs to be processed.  Here and in the comments below,
6538                  * we use the above sample data.  The t_cp chunk must be any
6539                  * contiguous subset of M, N, O, P, and/or Q.
6540                  *
6541                  * In the first pass, calculate if there is any possible input
6542                  * string that has a character whose transliteration will be
6543                  * longer than it.  If none, the transliteration may be done
6544                  * in-place, as it can't write over a so-far unread byte.
6545                  * Otherwise, a copy must first be made.  This could be
6546                  * expensive for long inputs.
6547                  *
6548                  * In the first pass, the t_invlist has been partitioned so
6549                  * that all elements in any single range have the same number
6550                  * of bytes in their UTF-8 representations.  And the r space is
6551                  * either a single byte, or a range of strictly monotonically
6552                  * increasing code points.  So the final element in the range
6553                  * will be represented by no fewer bytes than the initial one.
6554                  * That means that if the final code point in the t range has
6555                  * at least as many bytes as the final code point in the r,
6556                  * then all code points in the t range have at least as many
6557                  * bytes as their corresponding r range element.  But if that's
6558                  * not true, the transliteration of at least the final code
6559                  * point grows in length.  As an example, suppose we had
6560                  *      tr/\x{fff0}-\x{fff1}/\x{ffff}-\x{10000}/
6561                  * The UTF-8 for all but 10000 occupies 3 bytes on ASCII
6562                  * platforms.  We have deliberately set up the data structure
6563                  * so that any range in the lhs gets split into chunks for
6564                  * processing, such that every code point in a chunk has the
6565                  * same number of UTF-8 bytes.  We only have to check the final
6566                  * code point in the rhs against any code point in the lhs. */
6567                 if ( ! pass2
6568                     && r_cp_end != TR_SPECIAL_HANDLING
6569                     && CP_SKIP(t_cp_end) < CP_SKIP(r_cp_end))
6570                 {
6571                     /* Here, we will need to make a copy of the input string
6572                      * before doing the transliteration.  The worst possible
6573                      * case is an expansion ratio of 14:1. This is rare, and
6574                      * we'd rather allocate only the necessary amount of extra
6575                      * memory for that copy.  We can calculate the worst case
6576                      * for this particular transliteration is by keeping track
6577                      * of the expansion factor for each range.
6578                      *
6579                      * Consider tr/\xCB/\X{E000}/.  The maximum expansion
6580                      * factor is 1 byte going to 3 if the target string is not
6581                      * UTF-8, but 2 bytes going to 3 if it is in UTF-8.  We
6582                      * could pass two different values so doop could choose
6583                      * based on the UTF-8ness of the target.  But khw thinks
6584                      * (perhaps wrongly) that is overkill.  It is used only to
6585                      * make sure we malloc enough space.
6586                      *
6587                      * If no target string can force the result to be UTF-8,
6588                      * then we don't have to worry about the case of the target
6589                      * string not being UTF-8 */
6590                     NV t_size = (can_force_utf8 && t_cp < 256)
6591                                 ? 1
6592                                 : CP_SKIP(t_cp_end);
6593                     NV ratio = CP_SKIP(r_cp_end) / t_size;
6594 
6595                     o->op_private |= OPpTRANS_GROWS;
6596 
6597                     /* Now that we know it grows, we can keep track of the
6598                      * largest ratio */
6599                     if (ratio > max_expansion) {
6600                         max_expansion = ratio;
6601                         DEBUG_y(PerlIO_printf(Perl_debug_log,
6602                                         "New expansion factor: %" NVgf "\n",
6603                                         max_expansion));
6604                     }
6605                 }
6606 
6607                 /* The very first range is marked as adjacent to the
6608                  * non-existent range below it, as it causes things to "just
6609                  * work" (TradeMark)
6610                  *
6611                  * If the lowest code point in this chunk is M, it adjoins the
6612                  * J-L range */
6613                 if (t_cp == t_array[i]) {
6614                     adjacent_to_range_below = TRUE;
6615 
6616                     /* And if the map has the same offset from the beginning of
6617                      * the range as does this new code point (or both are for
6618                      * TR_SPECIAL_HANDLING), this chunk can be completely
6619                      * merged with the range below.  EXCEPT, in the first pass,
6620                      * we don't merge ranges whose UTF-8 byte representations
6621                      * have different lengths, so that we can more easily
6622                      * detect if a replacement is longer than the source, that
6623                      * is if it 'grows'.  But in the 2nd pass, there's no
6624                      * reason to not merge */
6625                     if (   (i > 0 && (   pass2
6626                                       || CP_SKIP(t_array[i-1])
6627                                                             == CP_SKIP(t_cp)))
6628                         && (   (   r_cp == TR_SPECIAL_HANDLING
6629                                 && r_map[i-1] == TR_SPECIAL_HANDLING)
6630                             || (   r_cp != TR_SPECIAL_HANDLING
6631                                 && r_cp - r_map[i-1] == t_cp - t_array[i-1])))
6632                     {
6633                         merge_with_range_below = TRUE;
6634                     }
6635                 }
6636 
6637                 /* Similarly, if the highest code point in this chunk is 'Q',
6638                  * it adjoins the range above, and if the map is suitable, can
6639                  * be merged with it */
6640                 if (    t_cp_end >= IV_MAX - 1
6641                     || (   i + 1 < len
6642                         && t_cp_end + 1 == t_array[i+1]))
6643                 {
6644                     adjacent_to_range_above = TRUE;
6645                     if (i + 1 < len)
6646                     if (    (   pass2
6647                              || CP_SKIP(t_cp) == CP_SKIP(t_array[i+1]))
6648                         && (   (   r_cp == TR_SPECIAL_HANDLING
6649                                 && r_map[i+1] == (UV) TR_SPECIAL_HANDLING)
6650                             || (   r_cp != TR_SPECIAL_HANDLING
6651                                 && r_cp_end == r_map[i+1] - 1)))
6652                     {
6653                         merge_with_range_above = TRUE;
6654                     }
6655                 }
6656 
6657                 if (merge_with_range_below && merge_with_range_above) {
6658 
6659                     /* Here the new chunk looks like M => m, ... Q => q; and
6660                      * the range above is like R => r, ....  Thus, the [i-1]
6661                      * and [i+1] ranges should be seamlessly melded so the
6662                      * result looks like
6663                      *
6664                      * [i-1]    J   j   # J-T => j-t
6665                      * [i]      U   y   # U => y, V => y+1, ...
6666                      * ...
6667                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6668                      */
6669                     Move(t_array + i + 2, t_array + i, len - i - 2, UV);
6670                     Move(r_map   + i + 2, r_map   + i, len - i - 2, UV);
6671                     len -= 2;
6672                     invlist_set_len(t_invlist,
6673                                     len,
6674                                     *(get_invlist_offset_addr(t_invlist)));
6675                 }
6676                 else if (merge_with_range_below) {
6677 
6678                     /* Here the new chunk looks like M => m, .... But either
6679                      * (or both) it doesn't extend all the way up through Q; or
6680                      * the range above doesn't start with R => r. */
6681                     if (! adjacent_to_range_above) {
6682 
6683                         /* In the first case, let's say the new chunk extends
6684                          * through O.  We then want:
6685                          *
6686                          * [i-1]    J   j   # J-O => j-o
6687                          * [i]      P  -1   # P => -1, Q => -1
6688                          * [i+1]    R   x   # R => x, S => x+1, T => x+2
6689                          * [i+2]    U   y   # U => y, V => y+1, ...
6690                          * ...
6691                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6692                          *                                            infinity
6693                          */
6694                         t_array[i] = t_cp_end + 1;
6695                         r_map[i] = TR_UNLISTED;
6696                     }
6697                     else { /* Adjoins the range above, but can't merge with it
6698                               (because 'x' is not the next map after q) */
6699                         /*
6700                          * [i-1]    J   j   # J-Q => j-q
6701                          * [i]      R   x   # R => x, S => x+1, T => x+2
6702                          * [i+1]    U   y   # U => y, V => y+1, ...
6703                          * ...
6704                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6705                          *                                          infinity
6706                          */
6707 
6708                         Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6709                         Move(r_map + i + 1, r_map + i, len - i - 1, UV);
6710                         len--;
6711                         invlist_set_len(t_invlist, len,
6712                                         *(get_invlist_offset_addr(t_invlist)));
6713                     }
6714                 }
6715                 else if (merge_with_range_above) {
6716 
6717                     /* Here the new chunk ends with Q => q, and the range above
6718                      * must start with R => r, so the two can be merged. But
6719                      * either (or both) the new chunk doesn't extend all the
6720                      * way down to M; or the mapping of the final code point
6721                      * range below isn't m */
6722                     if (! adjacent_to_range_below) {
6723 
6724                         /* In the first case, let's assume the new chunk starts
6725                          * with P => p.  Then, because it's merge-able with the
6726                          * range above, that range must be R => r.  We want:
6727                          *
6728                          * [i-1]    J   j   # J-L => j-l
6729                          * [i]      M  -1   # M => -1, N => -1
6730                          * [i+1]    P   p   # P-T => p-t
6731                          * [i+2]    U   y   # U => y, V => y+1, ...
6732                          * ...
6733                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6734                          *                                          infinity
6735                          */
6736                         t_array[i+1] = t_cp;
6737                         r_map[i+1] = r_cp;
6738                     }
6739                     else { /* Adjoins the range below, but can't merge with it
6740                             */
6741                         /*
6742                          * [i-1]    J   j   # J-L => j-l
6743                          * [i]      M   x   # M-T => x-5 .. x+2
6744                          * [i+1]    U   y   # U => y, V => y+1, ...
6745                          * ...
6746                          * [-1]     Z  -1   # Z => default; as do Z+1, ...
6747                          *                                          infinity
6748                          */
6749                         Move(t_array + i + 1, t_array + i, len - i - 1, UV);
6750                         Move(r_map   + i + 1, r_map   + i, len - i - 1, UV);
6751                         len--;
6752                         t_array[i] = t_cp;
6753                         r_map[i] = r_cp;
6754                         invlist_set_len(t_invlist, len,
6755                                         *(get_invlist_offset_addr(t_invlist)));
6756                     }
6757                 }
6758                 else if (adjacent_to_range_below && adjacent_to_range_above) {
6759                     /* The new chunk completely fills the gap between the
6760                      * ranges on either side, but can't merge with either of
6761                      * them.
6762                      *
6763                      * [i-1]    J   j   # J-L => j-l
6764                      * [i]      M   z   # M => z, N => z+1 ... Q => z+4
6765                      * [i+1]    R   x   # R => x, S => x+1, T => x+2
6766                      * [i+2]    U   y   # U => y, V => y+1, ...
6767                      * ...
6768                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6769                      */
6770                     r_map[i] = r_cp;
6771                 }
6772                 else if (adjacent_to_range_below) {
6773                     /* The new chunk adjoins the range below, but not the range
6774                      * above, and can't merge.  Let's assume the chunk ends at
6775                      * O.
6776                      *
6777                      * [i-1]    J   j   # J-L => j-l
6778                      * [i]      M   z   # M => z, N => z+1, O => z+2
6779                      * [i+1]    P   -1  # P => -1, Q => -1
6780                      * [i+2]    R   x   # R => x, S => x+1, T => x+2
6781                      * [i+3]    U   y   # U => y, V => y+1, ...
6782                      * ...
6783                      * [-w]     Z  -1   # Z => default; as do Z+1, ... infinity
6784                      */
6785                     invlist_extend(t_invlist, len + 1);
6786                     t_array = invlist_array(t_invlist);
6787                     Renew(r_map, len + 1, UV);
6788 
6789                     Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6790                     Move(r_map + i + 1,   r_map   + i + 2, len - i - 1, UV);
6791                     r_map[i] = r_cp;
6792                     t_array[i+1] = t_cp_end + 1;
6793                     r_map[i+1] = TR_UNLISTED;
6794                     len++;
6795                     invlist_set_len(t_invlist, len,
6796                                     *(get_invlist_offset_addr(t_invlist)));
6797                 }
6798                 else if (adjacent_to_range_above) {
6799                     /* The new chunk adjoins the range above, but not the range
6800                      * below, and can't merge.  Let's assume the new chunk
6801                      * starts at O
6802                      *
6803                      * [i-1]    J   j   # J-L => j-l
6804                      * [i]      M  -1   # M => default, N => default
6805                      * [i+1]    O   z   # O => z, P => z+1, Q => z+2
6806                      * [i+2]    R   x   # R => x, S => x+1, T => x+2
6807                      * [i+3]    U   y   # U => y, V => y+1, ...
6808                      * ...
6809                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6810                      */
6811                     invlist_extend(t_invlist, len + 1);
6812                     t_array = invlist_array(t_invlist);
6813                     Renew(r_map, len + 1, UV);
6814 
6815                     Move(t_array + i + 1, t_array + i + 2, len - i - 1, UV);
6816                     Move(r_map   + i + 1, r_map   + i + 2, len - i - 1, UV);
6817                     t_array[i+1] = t_cp;
6818                     r_map[i+1] = r_cp;
6819                     len++;
6820                     invlist_set_len(t_invlist, len,
6821                                     *(get_invlist_offset_addr(t_invlist)));
6822                 }
6823                 else {
6824                     /* The new chunk adjoins neither the range above, nor the
6825                      * range below.  Lets assume it is N..P => n..p
6826                      *
6827                      * [i-1]    J   j   # J-L => j-l
6828                      * [i]      M  -1   # M => default
6829                      * [i+1]    N   n   # N..P => n..p
6830                      * [i+2]    Q  -1   # Q => default
6831                      * [i+3]    R   x   # R => x, S => x+1, T => x+2
6832                      * [i+4]    U   y   # U => y, V => y+1, ...
6833                      * ...
6834                      * [-1]     Z  -1   # Z => default; as do Z+1, ... infinity
6835                      */
6836 
6837                     DEBUG_yv(PerlIO_printf(Perl_debug_log,
6838                                         "Before fixing up: len=%d, i=%d\n",
6839                                         (int) len, (int) i));
6840                     DEBUG_yv(invmap_dump(t_invlist, r_map));
6841 
6842                     invlist_extend(t_invlist, len + 2);
6843                     t_array = invlist_array(t_invlist);
6844                     Renew(r_map, len + 2, UV);
6845 
6846                     Move(t_array + i + 1,
6847                          t_array + i + 2 + 1, len - i - (2 - 1), UV);
6848                     Move(r_map   + i + 1,
6849                          r_map   + i + 2 + 1, len - i - (2 - 1), UV);
6850 
6851                     len += 2;
6852                     invlist_set_len(t_invlist, len,
6853                                     *(get_invlist_offset_addr(t_invlist)));
6854 
6855                     t_array[i+1] = t_cp;
6856                     r_map[i+1] = r_cp;
6857 
6858                     t_array[i+2] = t_cp_end + 1;
6859                     r_map[i+2] = TR_UNLISTED;
6860                 }
6861                 DEBUG_yv(PerlIO_printf(Perl_debug_log,
6862                           "After iteration: span=%" UVuf ", t_range_count=%"
6863                           UVuf " r_range_count=%" UVuf "\n",
6864                           span, t_range_count, r_range_count));
6865                 DEBUG_yv(invmap_dump(t_invlist, r_map));
6866             } /* End of this chunk needs to be processed */
6867 
6868             /* Done with this chunk. */
6869             t_cp += span;
6870             if (t_cp >= IV_MAX) {
6871                 break;
6872             }
6873             t_range_count -= span;
6874             if (r_cp != TR_SPECIAL_HANDLING) {
6875                 r_cp += span;
6876                 r_range_count -= span;
6877             }
6878             else {
6879                 r_range_count = 0;
6880             }
6881 
6882         } /* End of loop through the search list */
6883 
6884         /* We don't need an exact count, but we do need to know if there is
6885          * anything left over in the replacement list.  So, just assume it's
6886          * one byte per character */
6887         if (rend > r) {
6888             r_count++;
6889         }
6890     } /* End of passes */
6891 
6892     SvREFCNT_dec(inverted_tstr);
6893 
6894     DEBUG_y(PerlIO_printf(Perl_debug_log, "After everything: \n"));
6895     DEBUG_y(invmap_dump(t_invlist, r_map));
6896 
6897     /* We now have normalized the input into an inversion map.
6898      *
6899      * See if the lhs and rhs are equivalent.  If so, this tr/// is a no-op
6900      * except for the count, and streamlined runtime code can be used */
6901     if (!del && !squash) {
6902 
6903         /* They are identical if they point to the same address, or if
6904          * everything maps to UNLISTED or to itself.  This catches things that
6905          * not looking at the normalized inversion map doesn't catch, like
6906          * tr/aa/ab/ or tr/\x{100}-\x{104}/\x{100}-\x{102}\x{103}-\x{104}  */
6907         if (r0 != t0) {
6908             for (i = 0; i < len; i++) {
6909                 if (r_map[i] != TR_UNLISTED && r_map[i] != t_array[i]) {
6910                     goto done_identical_check;
6911                 }
6912             }
6913         }
6914 
6915         /* Here have gone through entire list, and didn't find any
6916          * non-identical mappings */
6917         o->op_private |= OPpTRANS_IDENTICAL;
6918 
6919       done_identical_check: ;
6920     }
6921 
6922     t_array = invlist_array(t_invlist);
6923 
6924     /* If has components above 255, we generally need to use the inversion map
6925      * implementation */
6926     if (   can_force_utf8
6927         || (   len > 0
6928             && t_array[len-1] > 255
6929                  /* If the final range is 0x100-INFINITY and is a special
6930                   * mapping, the table implementation can handle it */
6931             && ! (   t_array[len-1] == 256
6932                   && (   r_map[len-1] == TR_UNLISTED
6933                       || r_map[len-1] == TR_SPECIAL_HANDLING))))
6934     {
6935         SV* r_map_sv;
6936         SV* temp_sv;
6937 
6938         /* A UTF-8 op is generated, indicated by this flag.  This op is an
6939          * sv_op */
6940         o->op_private |= OPpTRANS_USE_SVOP;
6941 
6942         if (can_force_utf8) {
6943             o->op_private |= OPpTRANS_CAN_FORCE_UTF8;
6944         }
6945 
6946         /* The inversion map is pushed; first the list. */
6947         invmap = MUTABLE_AV(newAV());
6948 
6949         SvREADONLY_on(t_invlist);
6950         av_push(invmap, t_invlist);
6951 
6952         /* 2nd is the mapping */
6953         r_map_sv = newSVpvn((char *) r_map, len * sizeof(UV));
6954         SvREADONLY_on(r_map_sv);
6955         av_push(invmap, r_map_sv);
6956 
6957         /* 3rd is the max possible expansion factor */
6958         temp_sv = newSVnv(max_expansion);
6959         SvREADONLY_on(temp_sv);
6960         av_push(invmap, temp_sv);
6961 
6962         /* Characters that are in the search list, but not in the replacement
6963          * list are mapped to the final character in the replacement list */
6964         if (! del && r_count < t_count) {
6965             temp_sv = newSVuv(final_map);
6966             SvREADONLY_on(temp_sv);
6967             av_push(invmap, temp_sv);
6968         }
6969 
6970 #ifdef USE_ITHREADS
6971         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
6972         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
6973         PAD_SETSV(cPADOPo->op_padix, (SV *) invmap);
6974         SvPADTMP_on(invmap);
6975         SvREADONLY_on(invmap);
6976 #else
6977         cSVOPo->op_sv = (SV *) invmap;
6978 #endif
6979 
6980     }
6981     else {
6982         OPtrans_map *tbl;
6983         unsigned short i;
6984 
6985         /* The OPtrans_map struct already contains one slot; hence the -1. */
6986         SSize_t struct_size = sizeof(OPtrans_map)
6987                             + (256 - 1 + 1)*sizeof(short);
6988 
6989         /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
6990          * table. Entries with the value TR_UNMAPPED indicate chars not to be
6991          * translated, while TR_DELETE indicates a search char without a
6992          * corresponding replacement char under /d.
6993          *
6994          * In addition, an extra slot at the end is used to store the final
6995          * repeating char, or TR_R_EMPTY under an empty replacement list, or
6996          * TR_DELETE under /d; which makes the runtime code easier. */
6997 
6998         /* Indicate this is an op_pv */
6999         o->op_private &= ~OPpTRANS_USE_SVOP;
7000 
7001         tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
7002         tbl->size = 256;
7003         cPVOPo->op_pv = (char*)tbl;
7004 
7005         for (i = 0; i < len; i++) {
7006             STATIC_ASSERT_DECL(TR_SPECIAL_HANDLING == TR_DELETE);
7007             short upper = i >= len - 1 ? 256 : (short) t_array[i+1];
7008             short to = (short) r_map[i];
7009             short j;
7010             bool do_increment = TRUE;
7011 
7012             /* Any code points above our limit should be irrelevant */
7013             if (t_array[i] >= tbl->size) break;
7014 
7015             /* Set up the map */
7016             if (to == (short) TR_SPECIAL_HANDLING && ! del) {
7017                 to = (short) final_map;
7018                 do_increment = FALSE;
7019             }
7020             else if (to < 0) {
7021                 do_increment = FALSE;
7022             }
7023 
7024             /* Create a map for everything in this range.  The value increases
7025              * except for the special cases */
7026             for (j = (short) t_array[i]; j < upper; j++) {
7027                 tbl->map[j] = to;
7028                 if (do_increment) to++;
7029             }
7030         }
7031 
7032         tbl->map[tbl->size] = del
7033                               ? (short) TR_DELETE
7034                               : (short) rlen
7035                                 ? (short) final_map
7036                                 : (short) TR_R_EMPTY;
7037         DEBUG_y(PerlIO_printf(Perl_debug_log,"%s: %d\n", __FILE__, __LINE__));
7038         for (i = 0; i < tbl->size; i++) {
7039             if (tbl->map[i] < 0) {
7040                 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%d",
7041                                                 (unsigned) i, tbl->map[i]));
7042             }
7043             else {
7044                 DEBUG_y(PerlIO_printf(Perl_debug_log," %02x=>%02x",
7045                                                 (unsigned) i, tbl->map[i]));
7046             }
7047             if ((i+1) % 8 == 0 || i + 1 == (short) tbl->size) {
7048                 DEBUG_y(PerlIO_printf(Perl_debug_log,"\n"));
7049             }
7050         }
7051         DEBUG_y(PerlIO_printf(Perl_debug_log,"Final map 0x%x=>%02x\n",
7052                                 (unsigned) tbl->size, tbl->map[tbl->size]));
7053 
7054         SvREFCNT_dec(t_invlist);
7055 
7056 #if 0   /* code that added excess above-255 chars at the end of the table, in
7057            case we ever want to not use the inversion map implementation for
7058            this */
7059 
7060         ASSUME(j <= rlen);
7061         excess = rlen - j;
7062 
7063         if (excess) {
7064             /* More replacement chars than search chars:
7065              * store excess replacement chars at end of main table.
7066              */
7067 
7068             struct_size += excess;
7069             tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
7070                         struct_size + excess * sizeof(short));
7071             tbl->size += excess;
7072             cPVOPo->op_pv = (char*)tbl;
7073 
7074             for (i = 0; i < excess; i++)
7075                 tbl->map[i + 256] = r[j+i];
7076         }
7077         else {
7078             /* no more replacement chars than search chars */
7079         }
7080 #endif
7081 
7082     }
7083 
7084     DEBUG_y(PerlIO_printf(Perl_debug_log,
7085             "/d=%d, /s=%d, /c=%d, identical=%d, grows=%d,"
7086             " use_svop=%d, can_force_utf8=%d,\nexpansion=%" NVgf "\n",
7087             del, squash, complement,
7088             cBOOL(o->op_private & OPpTRANS_IDENTICAL),
7089             cBOOL(o->op_private & OPpTRANS_USE_SVOP),
7090             cBOOL(o->op_private & OPpTRANS_GROWS),
7091             cBOOL(o->op_private & OPpTRANS_CAN_FORCE_UTF8),
7092             max_expansion));
7093 
7094     Safefree(r_map);
7095 
7096     if(del && rlen != 0 && r_count == t_count) {
7097         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
7098     } else if(r_count > t_count) {
7099         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
7100     }
7101 
7102     op_free(expr);
7103     op_free(repl);
7104 
7105     return o;
7106 }
7107 
7108 
7109 /*
7110 =for apidoc newPMOP
7111 
7112 Constructs, checks, and returns an op of any pattern matching type.
7113 C<type> is the opcode.  C<flags> gives the eight bits of C<op_flags>
7114 and, shifted up eight bits, the eight bits of C<op_private>.
7115 
7116 =cut
7117 */
7118 
7119 OP *
Perl_newPMOP(pTHX_ I32 type,I32 flags)7120 Perl_newPMOP(pTHX_ I32 type, I32 flags)
7121 {
7122     PMOP *pmop;
7123 
7124     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP
7125         || type == OP_CUSTOM);
7126 
7127     NewOp(1101, pmop, 1, PMOP);
7128     OpTYPE_set(pmop, type);
7129     pmop->op_flags = (U8)flags;
7130     pmop->op_private = (U8)(0 | (flags >> 8));
7131     if (PL_opargs[type] & OA_RETSCALAR)
7132         scalar((OP *)pmop);
7133 
7134     if (PL_hints & HINT_RE_TAINT)
7135         pmop->op_pmflags |= PMf_RETAINT;
7136 #ifdef USE_LOCALE_CTYPE
7137     if (IN_LC_COMPILETIME(LC_CTYPE)) {
7138         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
7139     }
7140     else
7141 #endif
7142          if (IN_UNI_8_BIT) {
7143         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
7144     }
7145     if (PL_hints & HINT_RE_FLAGS) {
7146         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7147          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
7148         );
7149         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
7150         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
7151          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
7152         );
7153         if (reflags && SvOK(reflags)) {
7154             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
7155         }
7156     }
7157 
7158 
7159 #ifdef USE_ITHREADS
7160     assert(SvPOK(PL_regex_pad[0]));
7161     if (SvCUR(PL_regex_pad[0])) {
7162         /* Pop off the "packed" IV from the end.  */
7163         SV *const repointer_list = PL_regex_pad[0];
7164         const char *p = SvEND(repointer_list) - sizeof(IV);
7165         const IV offset = *((IV*)p);
7166 
7167         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
7168 
7169         SvEND_set(repointer_list, p);
7170 
7171         pmop->op_pmoffset = offset;
7172         /* This slot should be free, so assert this:  */
7173         assert(PL_regex_pad[offset] == &PL_sv_undef);
7174     } else {
7175         SV * const repointer = &PL_sv_undef;
7176         av_push(PL_regex_padav, repointer);
7177         pmop->op_pmoffset = av_top_index(PL_regex_padav);
7178         PL_regex_pad = AvARRAY(PL_regex_padav);
7179     }
7180 #endif
7181 
7182     return CHECKOP(type, pmop);
7183 }
7184 
7185 static void
S_set_haseval(pTHX)7186 S_set_haseval(pTHX)
7187 {
7188     PADOFFSET i = 1;
7189     PL_cv_has_eval = 1;
7190     /* Any pad names in scope are potentially lvalues.  */
7191     for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
7192         PADNAME *pn = PAD_COMPNAME_SV(i);
7193         if (!pn || !PadnameLEN(pn))
7194             continue;
7195         if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
7196             S_mark_padname_lvalue(aTHX_ pn);
7197     }
7198 }
7199 
7200 /* Given some sort of match op o, and an expression expr containing a
7201  * pattern, either compile expr into a regex and attach it to o (if it's
7202  * constant), or convert expr into a runtime regcomp op sequence (if it's
7203  * not)
7204  *
7205  * Flags currently has 2 bits of meaning:
7206  * 1: isreg indicates that the pattern is part of a regex construct, eg
7207  *      $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
7208  *      split "pattern", which aren't. In the former case, expr will be a list
7209  *      if the pattern contains more than one term (eg /a$b/).
7210  * 2: The pattern is for a split.
7211  *
7212  * When the pattern has been compiled within a new anon CV (for
7213  * qr/(?{...})/ ), then floor indicates the savestack level just before
7214  * the new sub was created
7215  *
7216  * tr/// is also handled.
7217  */
7218 
7219 OP *
Perl_pmruntime(pTHX_ OP * o,OP * expr,OP * repl,UV flags,I32 floor)7220 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl, UV flags, I32 floor)
7221 {
7222     PMOP *pm;
7223     LOGOP *rcop;
7224     I32 repl_has_vars = 0;
7225     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
7226     bool is_compiletime;
7227     bool has_code;
7228     bool isreg    = cBOOL(flags & 1);
7229     bool is_split = cBOOL(flags & 2);
7230 
7231     PERL_ARGS_ASSERT_PMRUNTIME;
7232 
7233     if (is_trans) {
7234         return pmtrans(o, expr, repl);
7235     }
7236 
7237     /* find whether we have any runtime or code elements;
7238      * at the same time, temporarily set the op_next of each DO block;
7239      * then when we LINKLIST, this will cause the DO blocks to be excluded
7240      * from the op_next chain (and from having LINKLIST recursively
7241      * applied to them). We fix up the DOs specially later */
7242 
7243     is_compiletime = 1;
7244     has_code = 0;
7245     if (expr->op_type == OP_LIST) {
7246         OP *child;
7247         for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
7248             if (child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)) {
7249                 has_code = 1;
7250                 assert(!child->op_next);
7251                 if (UNLIKELY(!OpHAS_SIBLING(child))) {
7252                     assert(PL_parser && PL_parser->error_count);
7253                     /* This can happen with qr/ (?{(^{})/.  Just fake up
7254                        the op we were expecting to see, to avoid crashing
7255                        elsewhere.  */
7256                     op_sibling_splice(expr, child, 0,
7257                               newSVOP(OP_CONST, 0, &PL_sv_no));
7258                 }
7259                 child->op_next = OpSIBLING(child);
7260             }
7261             else if (child->op_type != OP_CONST && child->op_type != OP_PUSHMARK)
7262             is_compiletime = 0;
7263         }
7264     }
7265     else if (expr->op_type != OP_CONST)
7266         is_compiletime = 0;
7267 
7268     LINKLIST(expr);
7269 
7270     /* fix up DO blocks; treat each one as a separate little sub;
7271      * also, mark any arrays as LIST/REF */
7272 
7273     if (expr->op_type == OP_LIST) {
7274         OP *child;
7275         for (child = cLISTOPx(expr)->op_first; child; child = OpSIBLING(child)) {
7276 
7277             if (child->op_type == OP_PADAV || child->op_type == OP_RV2AV) {
7278                 assert( !(child->op_flags  & OPf_WANT));
7279                 /* push the array rather than its contents. The regex
7280                  * engine will retrieve and join the elements later */
7281                 child->op_flags |= (OPf_WANT_LIST | OPf_REF);
7282                 continue;
7283             }
7284 
7285             if (!(child->op_type == OP_NULL && (child->op_flags & OPf_SPECIAL)))
7286                 continue;
7287             child->op_next = NULL; /* undo temporary hack from above */
7288             scalar(child);
7289             LINKLIST(child);
7290             if (cLISTOPx(child)->op_first->op_type == OP_LEAVE) {
7291                 LISTOP *leaveop = cLISTOPx(cLISTOPx(child)->op_first);
7292                 /* skip ENTER */
7293                 assert(leaveop->op_first->op_type == OP_ENTER);
7294                 assert(OpHAS_SIBLING(leaveop->op_first));
7295                 child->op_next = OpSIBLING(leaveop->op_first);
7296                 /* skip leave */
7297                 assert(leaveop->op_flags & OPf_KIDS);
7298                 assert(leaveop->op_last->op_next == (OP*)leaveop);
7299                 leaveop->op_next = NULL; /* stop on last op */
7300                 op_null((OP*)leaveop);
7301             }
7302             else {
7303                 /* skip SCOPE */
7304                 OP *scope = cLISTOPx(child)->op_first;
7305                 assert(scope->op_type == OP_SCOPE);
7306                 assert(scope->op_flags & OPf_KIDS);
7307                 scope->op_next = NULL; /* stop on last op */
7308                 op_null(scope);
7309             }
7310 
7311             /* XXX optimize_optree() must be called on o before
7312              * CALL_PEEP(), as currently S_maybe_multiconcat() can't
7313              * currently cope with a peephole-optimised optree.
7314              * Calling optimize_optree() here ensures that condition
7315              * is met, but may mean optimize_optree() is applied
7316              * to the same optree later (where hopefully it won't do any
7317              * harm as it can't convert an op to multiconcat if it's
7318              * already been converted */
7319             optimize_optree(child);
7320 
7321             /* have to peep the DOs individually as we've removed it from
7322              * the op_next chain */
7323             CALL_PEEP(child);
7324             op_prune_chain_head(&(child->op_next));
7325             if (is_compiletime)
7326                 /* runtime finalizes as part of finalizing whole tree */
7327                 finalize_optree(child);
7328         }
7329     }
7330     else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
7331         assert( !(expr->op_flags  & OPf_WANT));
7332         /* push the array rather than its contents. The regex
7333          * engine will retrieve and join the elements later */
7334         expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
7335     }
7336 
7337     PL_hints |= HINT_BLOCK_SCOPE;
7338     pm = cPMOPo;
7339     assert(floor==0 || (pm->op_pmflags & PMf_HAS_CV));
7340 
7341     if (is_compiletime) {
7342         U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
7343         regexp_engine const *eng = current_re_engine();
7344 
7345         if (is_split) {
7346             /* make engine handle split ' ' specially */
7347             pm->op_pmflags |= PMf_SPLIT;
7348             rx_flags |= RXf_SPLIT;
7349         }
7350 
7351         if (!has_code || !eng->op_comp) {
7352             /* compile-time simple constant pattern */
7353 
7354             if ((pm->op_pmflags & PMf_HAS_CV) && !has_code) {
7355                 /* whoops! we guessed that a qr// had a code block, but we
7356                  * were wrong (e.g. /[(?{}]/ ). Throw away the PL_compcv
7357                  * that isn't required now. Note that we have to be pretty
7358                  * confident that nothing used that CV's pad while the
7359                  * regex was parsed, except maybe op targets for \Q etc.
7360                  * If there were any op targets, though, they should have
7361                  * been stolen by constant folding.
7362                  */
7363 #ifdef DEBUGGING
7364                 SSize_t i = 0;
7365                 assert(PadnamelistMAXNAMED(PL_comppad_name) == 0);
7366                 while (++i <= AvFILLp(PL_comppad)) {
7367 #  ifdef USE_PAD_RESET
7368                     /* under USE_PAD_RESET, pad swipe replaces a swiped
7369                      * folded constant with a fresh padtmp */
7370                     assert(!PL_curpad[i] || SvPADTMP(PL_curpad[i]));
7371 #  else
7372                     assert(!PL_curpad[i]);
7373 #  endif
7374                 }
7375 #endif
7376                 /* This LEAVE_SCOPE will restore PL_compcv to point to the
7377                  * outer CV (the one whose slab holds the pm op). The
7378                  * inner CV (which holds expr) will be freed later, once
7379                  * all the entries on the parse stack have been popped on
7380                  * return from this function. Which is why its safe to
7381                  * call op_free(expr) below.
7382                  */
7383                 LEAVE_SCOPE(floor);
7384                 pm->op_pmflags &= ~PMf_HAS_CV;
7385             }
7386 
7387             /* Skip compiling if parser found an error for this pattern */
7388             if (pm->op_pmflags & PMf_HAS_ERROR) {
7389                 return o;
7390             }
7391 
7392             PM_SETRE(pm,
7393                 eng->op_comp
7394                     ? eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7395                                         rx_flags, pm->op_pmflags)
7396                     : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7397                                         rx_flags, pm->op_pmflags)
7398             );
7399             op_free(expr);
7400         }
7401         else {
7402             /* compile-time pattern that includes literal code blocks */
7403 
7404             REGEXP* re;
7405 
7406             /* Skip compiling if parser found an error for this pattern */
7407             if (pm->op_pmflags & PMf_HAS_ERROR) {
7408                 return o;
7409             }
7410 
7411             re = eng->op_comp(aTHX_ NULL, 0, expr, eng, NULL, NULL,
7412                         rx_flags,
7413                         (pm->op_pmflags |
7414                             ((PL_hints & HINT_RE_EVAL) ? PMf_USE_RE_EVAL : 0))
7415                     );
7416             PM_SETRE(pm, re);
7417             if (pm->op_pmflags & PMf_HAS_CV) {
7418                 CV *cv;
7419                 /* this QR op (and the anon sub we embed it in) is never
7420                  * actually executed. It's just a placeholder where we can
7421                  * squirrel away expr in op_code_list without the peephole
7422                  * optimiser etc processing it for a second time */
7423                 OP *qr = newPMOP(OP_QR, 0);
7424                 cPMOPx(qr)->op_code_list = expr;
7425 
7426                 /* handle the implicit sub{} wrapped round the qr/(?{..})/ */
7427                 SvREFCNT_inc_simple_void(PL_compcv);
7428                 cv = newATTRSUB(floor, 0, NULL, NULL, qr);
7429                 ReANY(re)->qr_anoncv = cv;
7430 
7431                 /* attach the anon CV to the pad so that
7432                  * pad_fixup_inner_anons() can find it */
7433                 (void)pad_add_anon(cv, o->op_type);
7434                 SvREFCNT_inc_simple_void(cv);
7435             }
7436             else {
7437                 pm->op_code_list = expr;
7438             }
7439         }
7440     }
7441     else {
7442         /* runtime pattern: build chain of regcomp etc ops */
7443         bool reglist;
7444         PADOFFSET cv_targ = 0;
7445 
7446         reglist = isreg && expr->op_type == OP_LIST;
7447         if (reglist)
7448             op_null(expr);
7449 
7450         if (has_code) {
7451             pm->op_code_list = expr;
7452             /* don't free op_code_list; its ops are embedded elsewhere too */
7453             pm->op_pmflags |= PMf_CODELIST_PRIVATE;
7454         }
7455 
7456         if (is_split)
7457             /* make engine handle split ' ' specially */
7458             pm->op_pmflags |= PMf_SPLIT;
7459 
7460         /* the OP_REGCMAYBE is a placeholder in the non-threaded case
7461          * to allow its op_next to be pointed past the regcomp and
7462          * preceding stacking ops;
7463          * OP_REGCRESET is there to reset taint before executing the
7464          * stacking ops */
7465         if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
7466             expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
7467 
7468         if (pm->op_pmflags & PMf_HAS_CV) {
7469             /* we have a runtime qr with literal code. This means
7470              * that the qr// has been wrapped in a new CV, which
7471              * means that runtime consts, vars etc will have been compiled
7472              * against a new pad. So... we need to execute those ops
7473              * within the environment of the new CV. So wrap them in a call
7474              * to a new anon sub. i.e. for
7475              *
7476              *     qr/a$b(?{...})/,
7477              *
7478              * we build an anon sub that looks like
7479              *
7480              *     sub { "a", $b, '(?{...})' }
7481              *
7482              * and call it, passing the returned list to regcomp.
7483              * Or to put it another way, the list of ops that get executed
7484              * are:
7485              *
7486              *     normal              PMf_HAS_CV
7487              *     ------              -------------------
7488              *                         pushmark (for regcomp)
7489              *                         pushmark (for entersub)
7490              *                         anoncode
7491              *                         entersub
7492              *     regcreset                  regcreset
7493              *     pushmark                   pushmark
7494              *     const("a")                 const("a")
7495              *     gvsv(b)                    gvsv(b)
7496              *     const("(?{...})")          const("(?{...})")
7497              *                                leavesub
7498              *     regcomp             regcomp
7499              */
7500 
7501             SvREFCNT_inc_simple_void(PL_compcv);
7502             CvLVALUE_on(PL_compcv);
7503             /* these lines are just an unrolled newANONATTRSUB */
7504             expr = newSVOP(OP_ANONCODE, OPf_REF,
7505                     MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
7506             cv_targ = expr->op_targ;
7507 
7508             expr = list(op_force_list(newUNOP(OP_ENTERSUB, 0, scalar(expr))));
7509         }
7510 
7511         rcop = alloc_LOGOP(OP_REGCOMP, scalar(expr), o);
7512         rcop->op_flags |=  ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
7513                            | (reglist ? OPf_STACKED : 0);
7514         rcop->op_targ = cv_targ;
7515 
7516         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
7517         if (PL_hints & HINT_RE_EVAL)
7518             S_set_haseval(aTHX);
7519 
7520         /* establish postfix order */
7521         if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
7522             LINKLIST(expr);
7523             rcop->op_next = expr;
7524             cUNOPx(expr)->op_first->op_next = (OP*)rcop;
7525         }
7526         else {
7527             rcop->op_next = LINKLIST(expr);
7528             expr->op_next = (OP*)rcop;
7529         }
7530 
7531         op_prepend_elem(o->op_type, scalar((OP*)rcop), o);
7532     }
7533 
7534     if (repl) {
7535         OP *curop = repl;
7536         bool konst;
7537         /* If we are looking at s//.../e with a single statement, get past
7538            the implicit do{}. */
7539         if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
7540              && cUNOPx(curop)->op_first->op_type == OP_SCOPE
7541              && cUNOPx(curop)->op_first->op_flags & OPf_KIDS)
7542          {
7543             OP *sib;
7544             OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
7545             if (kid->op_type == OP_NULL && (sib = OpSIBLING(kid))
7546              && !OpHAS_SIBLING(sib))
7547                 curop = sib;
7548         }
7549         if (curop->op_type == OP_CONST)
7550             konst = TRUE;
7551         else if (( (curop->op_type == OP_RV2SV ||
7552                     curop->op_type == OP_RV2AV ||
7553                     curop->op_type == OP_RV2HV ||
7554                     curop->op_type == OP_RV2GV)
7555                    && cUNOPx(curop)->op_first
7556                    && cUNOPx(curop)->op_first->op_type == OP_GV )
7557                 || curop->op_type == OP_PADSV
7558                 || curop->op_type == OP_PADAV
7559                 || curop->op_type == OP_PADHV
7560                 || curop->op_type == OP_PADANY) {
7561             repl_has_vars = 1;
7562             konst = TRUE;
7563         }
7564         else konst = FALSE;
7565         if (konst
7566             && !(repl_has_vars
7567                  && (!PM_GETRE(pm)
7568                      || !RX_PRELEN(PM_GETRE(pm))
7569                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
7570         {
7571             pm->op_pmflags |= PMf_CONST;	/* const for long enough */
7572             op_prepend_elem(o->op_type, scalar(repl), o);
7573         }
7574         else {
7575             rcop = alloc_LOGOP(OP_SUBSTCONT, scalar(repl), o);
7576             rcop->op_private = 1;
7577 
7578             /* establish postfix order */
7579             rcop->op_next = LINKLIST(repl);
7580             repl->op_next = (OP*)rcop;
7581 
7582             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
7583             assert(!(pm->op_pmflags & PMf_ONCE));
7584             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
7585             rcop->op_next = 0;
7586         }
7587     }
7588 
7589     return (OP*)pm;
7590 }
7591 
7592 /*
7593 =for apidoc newSVOP
7594 
7595 Constructs, checks, and returns an op of any type that involves an
7596 embedded SV.  C<type> is the opcode.  C<flags> gives the eight bits
7597 of C<op_flags>.  C<sv> gives the SV to embed in the op; this function
7598 takes ownership of one reference to it.
7599 
7600 =cut
7601 */
7602 
7603 OP *
Perl_newSVOP(pTHX_ I32 type,I32 flags,SV * sv)7604 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
7605 {
7606     SVOP *svop;
7607 
7608     PERL_ARGS_ASSERT_NEWSVOP;
7609 
7610     /* OP_RUNCV is allowed specially so rpeep has room to convert it into an
7611      * OP_CONST */
7612     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7613         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7614         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7615         || type == OP_RUNCV
7616         || type == OP_CUSTOM);
7617 
7618     NewOp(1101, svop, 1, SVOP);
7619     OpTYPE_set(svop, type);
7620     svop->op_sv = sv;
7621     svop->op_next = (OP*)svop;
7622     svop->op_flags = (U8)flags;
7623     svop->op_private = (U8)(0 | (flags >> 8));
7624     if (PL_opargs[type] & OA_RETSCALAR)
7625         scalar((OP*)svop);
7626     if (PL_opargs[type] & OA_TARGET)
7627         svop->op_targ = pad_alloc(type, SVs_PADTMP);
7628     return CHECKOP(type, svop);
7629 }
7630 
7631 /*
7632 =for apidoc newDEFSVOP
7633 
7634 Constructs and returns an op to access C<$_>.
7635 
7636 =cut
7637 */
7638 
7639 OP *
Perl_newDEFSVOP(pTHX)7640 Perl_newDEFSVOP(pTHX)
7641 {
7642         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
7643 }
7644 
7645 #ifdef USE_ITHREADS
7646 
7647 /*
7648 =for apidoc newPADOP
7649 
7650 Constructs, checks, and returns an op of any type that involves a
7651 reference to a pad element.  C<type> is the opcode.  C<flags> gives the
7652 eight bits of C<op_flags>.  A pad slot is automatically allocated, and
7653 is populated with C<sv>; this function takes ownership of one reference
7654 to it.
7655 
7656 This function only exists if Perl has been compiled to use ithreads.
7657 
7658 =cut
7659 */
7660 
7661 OP *
Perl_newPADOP(pTHX_ I32 type,I32 flags,SV * sv)7662 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
7663 {
7664     PADOP *padop;
7665 
7666     PERL_ARGS_ASSERT_NEWPADOP;
7667 
7668     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
7669         || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7670         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
7671         || type == OP_CUSTOM);
7672 
7673     NewOp(1101, padop, 1, PADOP);
7674     OpTYPE_set(padop, type);
7675     padop->op_padix =
7676         pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
7677     SvREFCNT_dec(PAD_SVl(padop->op_padix));
7678     PAD_SETSV(padop->op_padix, sv);
7679     assert(sv);
7680     padop->op_next = (OP*)padop;
7681     padop->op_flags = (U8)flags;
7682     if (PL_opargs[type] & OA_RETSCALAR)
7683         scalar((OP*)padop);
7684     if (PL_opargs[type] & OA_TARGET)
7685         padop->op_targ = pad_alloc(type, SVs_PADTMP);
7686     return CHECKOP(type, padop);
7687 }
7688 
7689 #endif /* USE_ITHREADS */
7690 
7691 /*
7692 =for apidoc newGVOP
7693 
7694 Constructs, checks, and returns an op of any type that involves an
7695 embedded reference to a GV.  C<type> is the opcode.  C<flags> gives the
7696 eight bits of C<op_flags>.  C<gv> identifies the GV that the op should
7697 reference; calling this function does not transfer ownership of any
7698 reference to it.
7699 
7700 =cut
7701 */
7702 
7703 OP *
Perl_newGVOP(pTHX_ I32 type,I32 flags,GV * gv)7704 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
7705 {
7706     PERL_ARGS_ASSERT_NEWGVOP;
7707 
7708 #ifdef USE_ITHREADS
7709     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7710 #else
7711     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
7712 #endif
7713 }
7714 
7715 /*
7716 =for apidoc newPVOP
7717 
7718 Constructs, checks, and returns an op of any type that involves an
7719 embedded C-level pointer (PV).  C<type> is the opcode.  C<flags> gives
7720 the eight bits of C<op_flags>.  C<pv> supplies the C-level pointer.
7721 Depending on the op type, the memory referenced by C<pv> may be freed
7722 when the op is destroyed.  If the op is of a freeing type, C<pv> must
7723 have been allocated using C<PerlMemShared_malloc>.
7724 
7725 =cut
7726 */
7727 
7728 OP *
Perl_newPVOP(pTHX_ I32 type,I32 flags,char * pv)7729 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
7730 {
7731     const bool utf8 = cBOOL(flags & SVf_UTF8);
7732     PVOP *pvop;
7733 
7734     flags &= ~SVf_UTF8;
7735 
7736     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
7737         || type == OP_CUSTOM
7738         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
7739 
7740     NewOp(1101, pvop, 1, PVOP);
7741     OpTYPE_set(pvop, type);
7742     pvop->op_pv = pv;
7743     pvop->op_next = (OP*)pvop;
7744     pvop->op_flags = (U8)flags;
7745     pvop->op_private = utf8 ? OPpPV_IS_UTF8 : 0;
7746     if (PL_opargs[type] & OA_RETSCALAR)
7747         scalar((OP*)pvop);
7748     if (PL_opargs[type] & OA_TARGET)
7749         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
7750     return CHECKOP(type, pvop);
7751 }
7752 
7753 void
Perl_package(pTHX_ OP * o)7754 Perl_package(pTHX_ OP *o)
7755 {
7756     SV *const sv = cSVOPo->op_sv;
7757 
7758     PERL_ARGS_ASSERT_PACKAGE;
7759 
7760     SAVEGENERICSV(PL_curstash);
7761     save_item(PL_curstname);
7762 
7763     PL_curstash = (HV *)SvREFCNT_inc(gv_stashsv(sv, GV_ADD));
7764 
7765     sv_setsv(PL_curstname, sv);
7766 
7767     PL_hints |= HINT_BLOCK_SCOPE;
7768     PL_parser->copline = NOLINE;
7769 
7770     op_free(o);
7771 }
7772 
7773 void
Perl_package_version(pTHX_ OP * v)7774 Perl_package_version( pTHX_ OP *v )
7775 {
7776     U32 savehints = PL_hints;
7777     PERL_ARGS_ASSERT_PACKAGE_VERSION;
7778     PL_hints &= ~HINT_STRICT_VARS;
7779     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
7780     PL_hints = savehints;
7781     op_free(v);
7782 }
7783 
7784 /* Extract the first two components of a "version" object as two 8bit integers
7785  * and return them packed into a single U16 in the format of PL_prevailing_version.
7786  * This function only ever has to cope with version objects already known
7787  * bounded by the current perl version, so we know its components will fit
7788  * (Up until we reach perl version 5.256 anyway) */
S_extract_shortver(pTHX_ SV * sv)7789 static U16 S_extract_shortver(pTHX_ SV *sv)
7790 {
7791     SV *rv;
7792     if(!SvRV(sv) || !SvOBJECT(rv = SvRV(sv)) || !sv_derived_from(sv, "version"))
7793         return 0;
7794 
7795     AV *av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rv), "version", 0)));
7796 
7797     U16 shortver = 0;
7798 
7799     IV major = av_count(av) > 0 ? SvIV(*av_fetch(av, 0, false)) : 0;
7800     if(major > 255)
7801         shortver |= 255 << 8;
7802     else
7803         shortver |= major << 8;
7804 
7805     IV minor = av_count(av) > 1 ? SvIV(*av_fetch(av, 1, false)) : 0;
7806     if(minor > 255)
7807         shortver |= 255;
7808     else
7809         shortver |= minor;
7810 
7811     return shortver;
7812 }
7813 #define SHORTVER(maj,min) ((maj << 8) | min)
7814 
7815 void
Perl_utilize(pTHX_ int aver,I32 floor,OP * version,OP * idop,OP * arg)7816 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
7817 {
7818     OP *pack;
7819     OP *imop;
7820     OP *veop;
7821     SV *use_version = NULL;
7822 
7823     PERL_ARGS_ASSERT_UTILIZE;
7824 
7825     if (idop->op_type != OP_CONST)
7826         Perl_croak(aTHX_ "Module name must be constant");
7827 
7828     veop = NULL;
7829 
7830     if (version) {
7831         SV * const vesv = cSVOPx(version)->op_sv;
7832 
7833         if (!arg && !SvNIOKp(vesv)) {
7834             arg = version;
7835         }
7836         else {
7837             OP *pack;
7838             SV *meth;
7839 
7840             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
7841                 Perl_croak(aTHX_ "Version number must be a constant number");
7842 
7843             /* Make copy of idop so we don't free it twice */
7844             pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
7845 
7846             /* Fake up a method call to VERSION */
7847             meth = newSVpvs_share("VERSION");
7848             veop = op_convert_list(OP_ENTERSUB, OPf_STACKED,
7849                             op_append_elem(OP_LIST,
7850                                         op_prepend_elem(OP_LIST, pack, version),
7851                                         newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
7852         }
7853     }
7854 
7855     /* Fake up an import/unimport */
7856     if (arg && arg->op_type == OP_STUB) {
7857         imop = arg;		/* no import on explicit () */
7858     }
7859     else if (SvNIOKp(cSVOPx(idop)->op_sv)) {
7860         imop = NULL;		/* use 5.0; */
7861         if (aver)
7862             use_version = cSVOPx(idop)->op_sv;
7863         else
7864             idop->op_private |= OPpCONST_NOVER;
7865     }
7866     else {
7867         SV *meth;
7868 
7869         /* Make copy of idop so we don't free it twice */
7870         pack = newSVOP(OP_CONST, 0, newSVsv(cSVOPx(idop)->op_sv));
7871 
7872         /* Fake up a method call to import/unimport */
7873         meth = aver
7874             ? newSVpvs_share("import") : newSVpvs_share("unimport");
7875         imop = op_convert_list(OP_ENTERSUB, OPf_STACKED,
7876                        op_append_elem(OP_LIST,
7877                                    op_prepend_elem(OP_LIST, pack, arg),
7878                                    newMETHOP_named(OP_METHOD_NAMED, 0, meth)
7879                        ));
7880     }
7881 
7882     /* Fake up the BEGIN {}, which does its thing immediately. */
7883     newATTRSUB(floor,
7884         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
7885         NULL,
7886         NULL,
7887         op_append_elem(OP_LINESEQ,
7888             op_append_elem(OP_LINESEQ,
7889                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
7890                 newSTATEOP(0, NULL, veop)),
7891             newSTATEOP(0, NULL, imop) ));
7892 
7893     if (use_version) {
7894         /* Enable the
7895          * feature bundle that corresponds to the required version. */
7896         use_version = sv_2mortal(new_version(use_version));
7897         S_enable_feature_bundle(aTHX_ use_version);
7898 
7899         U16 shortver = S_extract_shortver(aTHX_ use_version);
7900 
7901         /* If a version >= 5.11.0 is requested, strictures are on by default! */
7902         if (shortver >= SHORTVER(5, 11)) {
7903             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7904                 PL_hints |= HINT_STRICT_REFS;
7905             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7906                 PL_hints |= HINT_STRICT_SUBS;
7907             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7908                 PL_hints |= HINT_STRICT_VARS;
7909 
7910             if (shortver >= SHORTVER(5, 35))
7911                 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
7912         }
7913         /* otherwise they are off */
7914         else {
7915             if(PL_prevailing_version >= SHORTVER(5, 11))
7916                 deprecate_fatal_in(WARN_DEPRECATED__VERSION_DOWNGRADE, "5.40",
7917                     "Downgrading a use VERSION declaration to below v5.11");
7918 
7919             if (!(PL_hints & HINT_EXPLICIT_STRICT_REFS))
7920                 PL_hints &= ~HINT_STRICT_REFS;
7921             if (!(PL_hints & HINT_EXPLICIT_STRICT_SUBS))
7922                 PL_hints &= ~HINT_STRICT_SUBS;
7923             if (!(PL_hints & HINT_EXPLICIT_STRICT_VARS))
7924                 PL_hints &= ~HINT_STRICT_VARS;
7925         }
7926 
7927         PL_prevailing_version = shortver;
7928     }
7929 
7930     /* The "did you use incorrect case?" warning used to be here.
7931      * The problem is that on case-insensitive filesystems one
7932      * might get false positives for "use" (and "require"):
7933      * "use Strict" or "require CARP" will work.  This causes
7934      * portability problems for the script: in case-strict
7935      * filesystems the script will stop working.
7936      *
7937      * The "incorrect case" warning checked whether "use Foo"
7938      * imported "Foo" to your namespace, but that is wrong, too:
7939      * there is no requirement nor promise in the language that
7940      * a Foo.pm should or would contain anything in package "Foo".
7941      *
7942      * There is very little Configure-wise that can be done, either:
7943      * the case-sensitivity of the build filesystem of Perl does not
7944      * help in guessing the case-sensitivity of the runtime environment.
7945      */
7946 
7947     PL_hints |= HINT_BLOCK_SCOPE;
7948     PL_parser->copline = NOLINE;
7949     COP_SEQMAX_INC; /* Purely for B::*'s benefit */
7950 }
7951 
7952 /*
7953 =for apidoc_section $embedding
7954 
7955 =for apidoc      load_module
7956 =for apidoc_item load_module_nocontext
7957 
7958 These load the module whose name is pointed to by the string part of C<name>.
7959 Note that the actual module name, not its filename, should be given.
7960 Eg, "Foo::Bar" instead of "Foo/Bar.pm". ver, if specified and not NULL,
7961 provides version semantics similar to C<use Foo::Bar VERSION>. The optional
7962 trailing arguments can be used to specify arguments to the module's C<import()>
7963 method, similar to C<use Foo::Bar VERSION LIST>; their precise handling depends
7964 on the flags. The flags argument is a bitwise-ORed collection of any of
7965 C<PERL_LOADMOD_DENY>, C<PERL_LOADMOD_NOIMPORT>, or C<PERL_LOADMOD_IMPORT_OPS>
7966 (or 0 for no flags).
7967 
7968 If C<PERL_LOADMOD_NOIMPORT> is set, the module is loaded as if with an empty
7969 import list, as in C<use Foo::Bar ()>; this is the only circumstance in which
7970 the trailing optional arguments may be omitted entirely. Otherwise, if
7971 C<PERL_LOADMOD_IMPORT_OPS> is set, the trailing arguments must consist of
7972 exactly one C<OP*>, containing the op tree that produces the relevant import
7973 arguments. Otherwise, the trailing arguments must all be C<SV*> values that
7974 will be used as import arguments; and the list must be terminated with C<(SV*)
7975 NULL>. If neither C<PERL_LOADMOD_NOIMPORT> nor C<PERL_LOADMOD_IMPORT_OPS> is
7976 set, the trailing C<NULL> pointer is needed even if no import arguments are
7977 desired. The reference count for each specified C<SV*> argument is
7978 decremented. In addition, the C<name> argument is modified.
7979 
7980 If C<PERL_LOADMOD_DENY> is set, the module is loaded as if with C<no> rather
7981 than C<use>.
7982 
7983 C<load_module> and C<load_module_nocontext> have the same apparent signature,
7984 but the former hides the fact that it is accessing a thread context parameter.
7985 So use the latter when you get a compilation error about C<pTHX>.
7986 
7987 =for apidoc Amnh||PERL_LOADMOD_DENY
7988 =for apidoc Amnh||PERL_LOADMOD_NOIMPORT
7989 =for apidoc Amnh||PERL_LOADMOD_IMPORT_OPS
7990 
7991 =for apidoc vload_module
7992 Like C<L</load_module>> but the arguments are an encapsulated argument list.
7993 
7994 =cut */
7995 
7996 void
Perl_load_module(pTHX_ U32 flags,SV * name,SV * ver,...)7997 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
7998 {
7999     va_list args;
8000 
8001     PERL_ARGS_ASSERT_LOAD_MODULE;
8002 
8003     va_start(args, ver);
8004     vload_module(flags, name, ver, &args);
8005     va_end(args);
8006 }
8007 
8008 #ifdef MULTIPLICITY
8009 void
Perl_load_module_nocontext(U32 flags,SV * name,SV * ver,...)8010 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
8011 {
8012     dTHX;
8013     va_list args;
8014     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
8015     va_start(args, ver);
8016     vload_module(flags, name, ver, &args);
8017     va_end(args);
8018 }
8019 #endif
8020 
8021 void
Perl_vload_module(pTHX_ U32 flags,SV * name,SV * ver,va_list * args)8022 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
8023 {
8024     OP *veop, *imop;
8025     OP * modname;
8026     I32 floor;
8027 
8028     PERL_ARGS_ASSERT_VLOAD_MODULE;
8029 
8030     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
8031      * that it has a PL_parser to play with while doing that, and also
8032      * that it doesn't mess with any existing parser, by creating a tmp
8033      * new parser with lex_start(). This won't actually be used for much,
8034      * since pp_require() will create another parser for the real work.
8035      * The ENTER/LEAVE pair protect callers from any side effects of use.
8036      *
8037      * start_subparse() creates a new PL_compcv. This means that any ops
8038      * allocated below will be allocated from that CV's op slab, and so
8039      * will be automatically freed if the utilise() fails
8040      */
8041 
8042     ENTER;
8043     SAVEVPTR(PL_curcop);
8044     lex_start(NULL, NULL, LEX_START_SAME_FILTER);
8045     floor = start_subparse(FALSE, 0);
8046 
8047     modname = newSVOP(OP_CONST, 0, name);
8048     modname->op_private |= OPpCONST_BARE;
8049     if (ver) {
8050         veop = newSVOP(OP_CONST, 0, ver);
8051     }
8052     else
8053         veop = NULL;
8054     if (flags & PERL_LOADMOD_NOIMPORT) {
8055         imop = sawparens(newNULLLIST());
8056     }
8057     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
8058         imop = va_arg(*args, OP*);
8059     }
8060     else {
8061         SV *sv;
8062         imop = NULL;
8063         sv = va_arg(*args, SV*);
8064         while (sv) {
8065             imop = op_append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
8066             sv = va_arg(*args, SV*);
8067         }
8068     }
8069 
8070     utilize(!(flags & PERL_LOADMOD_DENY), floor, veop, modname, imop);
8071     LEAVE;
8072 }
8073 
8074 PERL_STATIC_INLINE OP *
S_new_entersubop(pTHX_ GV * gv,OP * arg)8075 S_new_entersubop(pTHX_ GV *gv, OP *arg)
8076 {
8077     return newUNOP(OP_ENTERSUB, OPf_STACKED,
8078                    newLISTOP(OP_LIST, 0, arg,
8079                              newUNOP(OP_RV2CV, 0,
8080                                      newGVOP(OP_GV, 0, gv))));
8081 }
8082 
8083 OP *
Perl_dofile(pTHX_ OP * term,I32 force_builtin)8084 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
8085 {
8086     OP *doop;
8087     GV *gv;
8088 
8089     PERL_ARGS_ASSERT_DOFILE;
8090 
8091     if (!force_builtin && (gv = gv_override("do", 2))) {
8092         doop = S_new_entersubop(aTHX_ gv, term);
8093     }
8094     else {
8095         doop = newUNOP(OP_DOFILE, 0, scalar(term));
8096     }
8097     return doop;
8098 }
8099 
8100 /*
8101 =for apidoc_section $optree_construction
8102 
8103 =for apidoc newSLICEOP
8104 
8105 Constructs, checks, and returns an C<lslice> (list slice) op.  C<flags>
8106 gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
8107 be set automatically, and, shifted up eight bits, the eight bits of
8108 C<op_private>, except that the bit with value 1 or 2 is automatically
8109 set as required.  C<listval> and C<subscript> supply the parameters of
8110 the slice; they are consumed by this function and become part of the
8111 constructed op tree.
8112 
8113 =cut
8114 */
8115 
8116 OP *
Perl_newSLICEOP(pTHX_ I32 flags,OP * subscript,OP * listval)8117 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
8118 {
8119     return newBINOP(OP_LSLICE, flags,
8120             list(op_force_list(subscript)),
8121             list(op_force_list(listval)));
8122 }
8123 
8124 #define ASSIGN_SCALAR 0
8125 #define ASSIGN_LIST   1
8126 #define ASSIGN_REF    2
8127 
8128 /* given the optree o on the LHS of an assignment, determine whether its:
8129  *  ASSIGN_SCALAR   $x  = ...
8130  *  ASSIGN_LIST    ($x) = ...
8131  *  ASSIGN_REF     \$x  = ...
8132  */
8133 
8134 STATIC I32
S_assignment_type(pTHX_ const OP * o)8135 S_assignment_type(pTHX_ const OP *o)
8136 {
8137     unsigned type;
8138     U8 flags;
8139     U8 ret;
8140 
8141     if (!o)
8142         return ASSIGN_LIST;
8143 
8144     if (o->op_type == OP_SREFGEN)
8145     {
8146         OP * const kid = cUNOPx(cUNOPo->op_first)->op_first;
8147         type = kid->op_type;
8148         flags = o->op_flags | kid->op_flags;
8149         if (!(flags & OPf_PARENS)
8150           && (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV ||
8151               kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV ))
8152             return ASSIGN_REF;
8153         ret = ASSIGN_REF;
8154     } else {
8155         if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
8156             o = cUNOPo->op_first;
8157         flags = o->op_flags;
8158         type = o->op_type;
8159         ret = ASSIGN_SCALAR;
8160     }
8161 
8162     if (type == OP_COND_EXPR) {
8163         OP * const sib = OpSIBLING(cLOGOPo->op_first);
8164         const I32 t = assignment_type(sib);
8165         const I32 f = assignment_type(OpSIBLING(sib));
8166 
8167         if (t == ASSIGN_LIST && f == ASSIGN_LIST)
8168             return ASSIGN_LIST;
8169         if ((t == ASSIGN_LIST) ^ (f == ASSIGN_LIST))
8170             yyerror("Assignment to both a list and a scalar");
8171         return ASSIGN_SCALAR;
8172     }
8173 
8174     if (type == OP_LIST &&
8175         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
8176         o->op_private & OPpLVAL_INTRO)
8177         return ret;
8178 
8179     if (type == OP_LIST || flags & OPf_PARENS ||
8180         type == OP_RV2AV || type == OP_RV2HV ||
8181         type == OP_ASLICE || type == OP_HSLICE ||
8182         type == OP_KVASLICE || type == OP_KVHSLICE || type == OP_REFGEN)
8183         return ASSIGN_LIST;
8184 
8185     if (type == OP_PADAV || type == OP_PADHV)
8186         return ASSIGN_LIST;
8187 
8188     if (type == OP_RV2SV)
8189         return ret;
8190 
8191     return ret;
8192 }
8193 
8194 static OP *
S_newONCEOP(pTHX_ OP * initop,OP * padop)8195 S_newONCEOP(pTHX_ OP *initop, OP *padop)
8196 {
8197     const PADOFFSET target = padop->op_targ;
8198     OP *const other = newOP(OP_PADSV,
8199                             padop->op_flags
8200                             | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
8201     OP *const first = newOP(OP_NULL, 0);
8202     OP *const nullop = newCONDOP(0, first, initop, other);
8203     /* XXX targlex disabled for now; see ticket #124160
8204         newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
8205      */
8206     OP *const condop = first->op_next;
8207 
8208     OpTYPE_set(condop, OP_ONCE);
8209     other->op_targ = target;
8210     nullop->op_flags |= OPf_WANT_SCALAR;
8211 
8212     /* Store the initializedness of state vars in a separate
8213        pad entry.  */
8214     condop->op_targ =
8215       pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
8216     /* hijacking PADSTALE for uninitialized state variables */
8217     SvPADSTALE_on(PAD_SVl(condop->op_targ));
8218 
8219     return nullop;
8220 }
8221 
8222 /*
8223 =for apidoc newARGDEFELEMOP
8224 
8225 Constructs and returns a new C<OP_ARGDEFELEM> op which provides a defaulting
8226 expression given by C<expr> for the signature parameter at the index given
8227 by C<argindex>. The expression optree is consumed by this function and
8228 becomes part of the returned optree.
8229 
8230 =cut
8231 */
8232 
8233 OP *
Perl_newARGDEFELEMOP(pTHX_ I32 flags,OP * expr,I32 argindex)8234 Perl_newARGDEFELEMOP(pTHX_ I32 flags, OP *expr, I32 argindex)
8235 {
8236     PERL_ARGS_ASSERT_NEWARGDEFELEMOP;
8237 
8238     OP *o = (OP *)alloc_LOGOP(OP_ARGDEFELEM, expr, LINKLIST(expr));
8239     o->op_flags |= (U8)(flags);
8240     o->op_private = 1 | (U8)(flags >> 8);
8241 
8242     /* re-purpose op_targ to hold @_ index */
8243     o->op_targ = (PADOFFSET)(argindex);
8244 
8245     return o;
8246 }
8247 
8248 /*
8249 =for apidoc newASSIGNOP
8250 
8251 Constructs, checks, and returns an assignment op.  C<left> and C<right>
8252 supply the parameters of the assignment; they are consumed by this
8253 function and become part of the constructed op tree.
8254 
8255 If C<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
8256 a suitable conditional optree is constructed.  If C<optype> is the opcode
8257 of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
8258 performs the binary operation and assigns the result to the left argument.
8259 Either way, if C<optype> is non-zero then C<flags> has no effect.
8260 
8261 If C<optype> is zero, then a plain scalar or list assignment is
8262 constructed.  Which type of assignment it is is automatically determined.
8263 C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8264 will be set automatically, and, shifted up eight bits, the eight bits
8265 of C<op_private>, except that the bit with value 1 or 2 is automatically
8266 set as required.
8267 
8268 =cut
8269 */
8270 
8271 OP *
Perl_newASSIGNOP(pTHX_ I32 flags,OP * left,I32 optype,OP * right)8272 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
8273 {
8274     OP *o;
8275     I32 assign_type;
8276 
8277     switch (optype) {
8278         case 0: break;
8279         case OP_ANDASSIGN:
8280         case OP_ORASSIGN:
8281         case OP_DORASSIGN:
8282             right = scalar(right);
8283             return newLOGOP(optype, 0,
8284                 op_lvalue(scalar(left), optype),
8285                 newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right));
8286         default:
8287             return newBINOP(optype, OPf_STACKED,
8288                 op_lvalue(scalar(left), optype), scalar(right));
8289     }
8290 
8291     if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
8292         OP *state_var_op = NULL;
8293         static const char no_list_state[] = "Initialization of state variables"
8294             " in list currently forbidden";
8295         OP *curop;
8296 
8297         if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
8298             left->op_private &= ~ OPpSLICEWARNING;
8299 
8300         PL_modcount = 0;
8301         left = op_lvalue(left, OP_AASSIGN);
8302         curop = list(op_force_list(left));
8303         o = newBINOP(OP_AASSIGN, flags, list(op_force_list(right)), curop);
8304         o->op_private = (U8)(0 | (flags >> 8));
8305 
8306         if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
8307         {
8308             OP *lop = cLISTOPx(left)->op_first, *vop, *eop;
8309             if (!(left->op_flags & OPf_PARENS) &&
8310                     lop->op_type == OP_PUSHMARK &&
8311                     (vop = OpSIBLING(lop)) &&
8312                     (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
8313                     !(vop->op_flags & OPf_PARENS) &&
8314                     (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
8315                         (OPpLVAL_INTRO|OPpPAD_STATE) &&
8316                     (eop = OpSIBLING(vop)) &&
8317                     eop->op_type == OP_ENTERSUB &&
8318                     !OpHAS_SIBLING(eop)) {
8319                 state_var_op = vop;
8320             } else {
8321                 while (lop) {
8322                     if ((lop->op_type == OP_PADSV ||
8323                          lop->op_type == OP_PADAV ||
8324                          lop->op_type == OP_PADHV ||
8325                          lop->op_type == OP_PADANY)
8326                       && (lop->op_private & OPpPAD_STATE)
8327                     )
8328                         yyerror(no_list_state);
8329                     lop = OpSIBLING(lop);
8330                 }
8331             }
8332         }
8333         else if (  (left->op_private & OPpLVAL_INTRO)
8334                 && (left->op_private & OPpPAD_STATE)
8335                 && (   left->op_type == OP_PADSV
8336                     || left->op_type == OP_PADAV
8337                     || left->op_type == OP_PADHV
8338                     || left->op_type == OP_PADANY)
8339         ) {
8340                 /* All single variable list context state assignments, hence
8341                    state ($a) = ...
8342                    (state $a) = ...
8343                    state @a = ...
8344                    state (@a) = ...
8345                    (state @a) = ...
8346                    state %a = ...
8347                    state (%a) = ...
8348                    (state %a) = ...
8349                 */
8350                 if (left->op_flags & OPf_PARENS)
8351                     yyerror(no_list_state);
8352                 else
8353                     state_var_op = left;
8354         }
8355 
8356         /* optimise @a = split(...) into:
8357         * @{expr}:              split(..., @{expr}) (where @a is not flattened)
8358         * @a, my @a, local @a:  split(...)          (where @a is attached to
8359         *                                            the split op itself)
8360         */
8361 
8362         if (   right
8363             && right->op_type == OP_SPLIT
8364             /* don't do twice, e.g. @b = (@a = split) */
8365             && !(right->op_private & OPpSPLIT_ASSIGN))
8366         {
8367             OP *gvop = NULL;
8368 
8369             if (   (  left->op_type == OP_RV2AV
8370                    && (gvop=cUNOPx(left)->op_first)->op_type==OP_GV)
8371                 || left->op_type == OP_PADAV)
8372             {
8373                 /* @pkg or @lex or local @pkg' or 'my @lex' */
8374                 OP *tmpop;
8375                 if (gvop) {
8376 #ifdef USE_ITHREADS
8377                     cPMOPx(right)->op_pmreplrootu.op_pmtargetoff
8378                         = cPADOPx(gvop)->op_padix;
8379                     cPADOPx(gvop)->op_padix = 0;	/* steal it */
8380 #else
8381                     cPMOPx(right)->op_pmreplrootu.op_pmtargetgv
8382                         = MUTABLE_GV(cSVOPx(gvop)->op_sv);
8383                     cSVOPx(gvop)->op_sv = NULL;	/* steal it */
8384 #endif
8385                     right->op_private |=
8386                         left->op_private & OPpOUR_INTRO;
8387                 }
8388                 else {
8389                     cPMOPx(right)->op_pmreplrootu.op_pmtargetoff = left->op_targ;
8390                     left->op_targ = 0;	/* steal it */
8391                     right->op_private |= OPpSPLIT_LEX;
8392                 }
8393                 right->op_private |= left->op_private & OPpLVAL_INTRO;
8394 
8395               detach_split:
8396                 tmpop = cUNOPo->op_first;	/* to list (nulled) */
8397                 tmpop = cUNOPx(tmpop)->op_first; /* to pushmark */
8398                 assert(OpSIBLING(tmpop) == right);
8399                 assert(!OpHAS_SIBLING(right));
8400                 /* detach the split subtreee from the o tree,
8401                  * then free the residual o tree */
8402                 op_sibling_splice(cUNOPo->op_first, tmpop, 1, NULL);
8403                 op_free(o);			/* blow off assign */
8404                 right->op_private |= OPpSPLIT_ASSIGN;
8405                 right->op_flags &= ~OPf_WANT;
8406                         /* "I don't know and I don't care." */
8407                 return right;
8408             }
8409             else if (left->op_type == OP_RV2AV) {
8410                 /* @{expr} */
8411 
8412                 OP *pushop = cUNOPx(cBINOPo->op_last)->op_first;
8413                 assert(OpSIBLING(pushop) == left);
8414                 /* Detach the array ...  */
8415                 op_sibling_splice(cBINOPo->op_last, pushop, 1, NULL);
8416                 /* ... and attach it to the split.  */
8417                 op_sibling_splice(right, cLISTOPx(right)->op_last,
8418                                   0, left);
8419                 right->op_flags |= OPf_STACKED;
8420                 /* Detach split and expunge aassign as above.  */
8421                 goto detach_split;
8422             }
8423             else if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
8424                     cLISTOPx(right)->op_last->op_type == OP_CONST)
8425             {
8426                 /* convert split(...,0) to split(..., PL_modcount+1) */
8427                 SV ** const svp =
8428                     &cSVOPx(cLISTOPx(right)->op_last)->op_sv;
8429                 SV * const sv = *svp;
8430                 if (SvIOK(sv) && SvIVX(sv) == 0)
8431                 {
8432                   if (right->op_private & OPpSPLIT_IMPLIM) {
8433                     /* our own SV, created in ck_split */
8434                     SvREADONLY_off(sv);
8435                     sv_setiv(sv, PL_modcount+1);
8436                   }
8437                   else {
8438                     /* SV may belong to someone else */
8439                     SvREFCNT_dec(sv);
8440                     *svp = newSViv(PL_modcount+1);
8441                   }
8442                 }
8443             }
8444         }
8445 
8446         if (state_var_op)
8447             o = S_newONCEOP(aTHX_ o, state_var_op);
8448         return o;
8449     }
8450     if (assign_type == ASSIGN_REF)
8451         return newBINOP(OP_REFASSIGN, flags, scalar(right), left);
8452     if (!right)
8453         right = newOP(OP_UNDEF, 0);
8454     if (right->op_type == OP_READLINE) {
8455         right->op_flags |= OPf_STACKED;
8456         return newBINOP(OP_NULL, flags, op_lvalue(scalar(left), OP_SASSIGN),
8457                 scalar(right));
8458     }
8459     else {
8460         o = newBINOP(OP_SASSIGN, flags,
8461             scalar(right), op_lvalue(scalar(left), OP_SASSIGN) );
8462     }
8463     return o;
8464 }
8465 
8466 /*
8467 =for apidoc newSTATEOP
8468 
8469 Constructs a state op (COP).  The state op is normally a C<nextstate> op,
8470 but will be a C<dbstate> op if debugging is enabled for currently-compiled
8471 code.  The state op is populated from C<PL_curcop> (or C<PL_compiling>).
8472 If C<label> is non-null, it supplies the name of a label to attach to
8473 the state op; this function takes ownership of the memory pointed at by
8474 C<label>, and will free it.  C<flags> gives the eight bits of C<op_flags>
8475 for the state op.
8476 
8477 If C<o> is null, the state op is returned.  Otherwise the state op is
8478 combined with C<o> into a C<lineseq> list op, which is returned.  C<o>
8479 is consumed by this function and becomes part of the returned op tree.
8480 
8481 =cut
8482 */
8483 
8484 OP *
Perl_newSTATEOP(pTHX_ I32 flags,char * label,OP * o)8485 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
8486 {
8487     const U32 seq = intro_my();
8488     const U32 utf8 = flags & SVf_UTF8;
8489     COP *cop;
8490 
8491     assert(PL_parser);
8492     PL_parser->parsed_sub = 0;
8493 
8494     flags &= ~SVf_UTF8;
8495 
8496     NewOp(1101, cop, 1, COP);
8497     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
8498         OpTYPE_set(cop, OP_DBSTATE);
8499     }
8500     else {
8501         OpTYPE_set(cop, OP_NEXTSTATE);
8502     }
8503     cop->op_flags = (U8)flags;
8504     CopHINTS_set(cop, PL_hints);
8505 #ifdef VMS
8506     if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
8507 #endif
8508     cop->op_next = (OP*)cop;
8509 
8510     cop->cop_seq = seq;
8511     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
8512     CopHINTHASH_set(cop, cophh_copy(CopHINTHASH_get(PL_curcop)));
8513     CopFEATURES_setfrom(cop, PL_curcop);
8514     if (label) {
8515         Perl_cop_store_label(aTHX_ cop, label, strlen(label), utf8);
8516 
8517         PL_hints |= HINT_BLOCK_SCOPE;
8518         /* It seems that we need to defer freeing this pointer, as other parts
8519            of the grammar end up wanting to copy it after this op has been
8520            created. */
8521         SAVEFREEPV(label);
8522     }
8523 
8524     if (PL_parser->preambling != NOLINE) {
8525         CopLINE_set(cop, PL_parser->preambling);
8526         PL_parser->copline = NOLINE;
8527     }
8528     else if (PL_parser->copline == NOLINE)
8529         CopLINE_set(cop, CopLINE(PL_curcop));
8530     else {
8531         CopLINE_set(cop, PL_parser->copline);
8532         PL_parser->copline = NOLINE;
8533     }
8534 #ifdef USE_ITHREADS
8535     CopFILE_copy(cop, PL_curcop);
8536 #else
8537     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
8538 #endif
8539     CopSTASH_set(cop, PL_curstash);
8540 
8541     if (cop->op_type == OP_DBSTATE) {
8542         /* this line can have a breakpoint - store the cop in IV */
8543         AV *av = CopFILEAVx(PL_curcop);
8544         if (av) {
8545             SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
8546             if (svp && *svp != &PL_sv_undef ) {
8547                 (void)SvIOK_on(*svp);
8548                 SvIV_set(*svp, PTR2IV(cop));
8549             }
8550         }
8551     }
8552 
8553     if (flags & OPf_SPECIAL)
8554         op_null((OP*)cop);
8555     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
8556 }
8557 
8558 /*
8559 =for apidoc newLOGOP
8560 
8561 Constructs, checks, and returns a logical (flow control) op.  C<type>
8562 is the opcode.  C<flags> gives the eight bits of C<op_flags>, except
8563 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
8564 the eight bits of C<op_private>, except that the bit with value 1 is
8565 automatically set.  C<first> supplies the expression controlling the
8566 flow, and C<other> supplies the side (alternate) chain of ops; they are
8567 consumed by this function and become part of the constructed op tree.
8568 
8569 =cut
8570 */
8571 
8572 OP *
Perl_newLOGOP(pTHX_ I32 type,I32 flags,OP * first,OP * other)8573 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
8574 {
8575     PERL_ARGS_ASSERT_NEWLOGOP;
8576 
8577     return new_logop(type, flags, &first, &other);
8578 }
8579 
8580 
8581 /* See if the optree o contains a single OP_CONST (plus possibly
8582  * surrounding enter/nextstate/null etc). If so, return it, else return
8583  * NULL.
8584  */
8585 
8586 STATIC OP *
S_search_const(pTHX_ OP * o)8587 S_search_const(pTHX_ OP *o)
8588 {
8589     PERL_ARGS_ASSERT_SEARCH_CONST;
8590 
8591   redo:
8592     switch (o->op_type) {
8593         case OP_CONST:
8594             return o;
8595         case OP_NULL:
8596             if (o->op_flags & OPf_KIDS) {
8597                 o = cUNOPo->op_first;
8598                 goto redo;
8599             }
8600             break;
8601         case OP_LEAVE:
8602         case OP_SCOPE:
8603         case OP_LINESEQ:
8604         {
8605             OP *kid;
8606             if (!(o->op_flags & OPf_KIDS))
8607                 return NULL;
8608             kid = cLISTOPo->op_first;
8609 
8610             do {
8611                 switch (kid->op_type) {
8612                     case OP_ENTER:
8613                     case OP_NULL:
8614                     case OP_NEXTSTATE:
8615                         kid = OpSIBLING(kid);
8616                         break;
8617                     default:
8618                         if (kid != cLISTOPo->op_last)
8619                             return NULL;
8620                         goto last;
8621                 }
8622             } while (kid);
8623 
8624             if (!kid)
8625                 kid = cLISTOPo->op_last;
8626           last:
8627              o = kid;
8628              goto redo;
8629         }
8630     }
8631 
8632     return NULL;
8633 }
8634 
8635 
8636 STATIC OP *
S_new_logop(pTHX_ I32 type,I32 flags,OP ** firstp,OP ** otherp)8637 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
8638 {
8639     LOGOP *logop;
8640     OP *o;
8641     OP *first;
8642     OP *other;
8643     OP *cstop = NULL;
8644     int prepend_not = 0;
8645 
8646     PERL_ARGS_ASSERT_NEW_LOGOP;
8647 
8648     first = *firstp;
8649     other = *otherp;
8650 
8651     /* [perl #59802]: Warn about things like "return $a or $b", which
8652        is parsed as "(return $a) or $b" rather than "return ($a or
8653        $b)".  NB: This also applies to xor, which is why we do it
8654        here.
8655      */
8656     switch (first->op_type) {
8657     case OP_NEXT:
8658     case OP_LAST:
8659     case OP_REDO:
8660         /* XXX: Perhaps we should emit a stronger warning for these.
8661            Even with the high-precedence operator they don't seem to do
8662            anything sensible.
8663 
8664            But until we do, fall through here.
8665          */
8666     case OP_RETURN:
8667     case OP_EXIT:
8668     case OP_DIE:
8669     case OP_GOTO:
8670         /* XXX: Currently we allow people to "shoot themselves in the
8671            foot" by explicitly writing "(return $a) or $b".
8672 
8673            Warn unless we are looking at the result from folding or if
8674            the programmer explicitly grouped the operators like this.
8675            The former can occur with e.g.
8676 
8677                 use constant FEATURE => ( $] >= ... );
8678                 sub { not FEATURE and return or do_stuff(); }
8679          */
8680         if (!first->op_folded && !(first->op_flags & OPf_PARENS))
8681             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
8682                            "Possible precedence issue with control flow operator");
8683         /* XXX: Should we optimze this to "return $a;" (i.e. remove
8684            the "or $b" part)?
8685         */
8686         break;
8687     }
8688 
8689     if (type == OP_XOR)		/* Not short circuit, but here by precedence. */
8690         return newBINOP(type, flags, scalar(first), scalar(other));
8691 
8692     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP
8693         || type == OP_CUSTOM);
8694 
8695     scalarboolean(first);
8696 
8697     /* search for a constant op that could let us fold the test */
8698     if ((cstop = search_const(first))) {
8699         if (cstop->op_private & OPpCONST_STRICT)
8700             no_bareword_allowed(cstop);
8701         else if ((cstop->op_private & OPpCONST_BARE))
8702                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
8703         if ((type == OP_AND &&  SvTRUE(cSVOPx(cstop)->op_sv)) ||
8704             (type == OP_OR  && !SvTRUE(cSVOPx(cstop)->op_sv)) ||
8705             (type == OP_DOR && !SvOK(cSVOPx(cstop)->op_sv))) {
8706             /* Elide the (constant) lhs, since it can't affect the outcome */
8707             *firstp = NULL;
8708             if (other->op_type == OP_CONST)
8709                 other->op_private |= OPpCONST_SHORTCIRCUIT;
8710             op_free(first);
8711             if (other->op_type == OP_LEAVE)
8712                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
8713             else if (other->op_type == OP_MATCH
8714                   || other->op_type == OP_SUBST
8715                   || other->op_type == OP_TRANSR
8716                   || other->op_type == OP_TRANS)
8717                 /* Mark the op as being unbindable with =~ */
8718                 other->op_flags |= OPf_SPECIAL;
8719 
8720             other->op_folded = 1;
8721             return other;
8722         }
8723         else {
8724             /* Elide the rhs, since the outcome is entirely determined by
8725              * the (constant) lhs */
8726 
8727             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
8728             const OP *o2 = other;
8729             if ( ! (o2->op_type == OP_LIST
8730                     && (( o2 = cUNOPx(o2)->op_first))
8731                     && o2->op_type == OP_PUSHMARK
8732                     && (( o2 = OpSIBLING(o2))) )
8733             )
8734                 o2 = other;
8735             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
8736                         || o2->op_type == OP_PADHV)
8737                 && o2->op_private & OPpLVAL_INTRO
8738                 && !(o2->op_private & OPpPAD_STATE))
8739             {
8740         Perl_croak(aTHX_ "This use of my() in false conditional is "
8741                           "no longer allowed");
8742             }
8743 
8744             *otherp = NULL;
8745             if (cstop->op_type == OP_CONST)
8746                 cstop->op_private |= OPpCONST_SHORTCIRCUIT;
8747             op_free(other);
8748             return first;
8749         }
8750     }
8751     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
8752         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
8753     {
8754         const OP * const k1 = cUNOPx(first)->op_first;
8755         const OP * const k2 = OpSIBLING(k1);
8756         OPCODE warnop = 0;
8757         switch (first->op_type)
8758         {
8759         case OP_NULL:
8760             if (k2 && k2->op_type == OP_READLINE
8761                   && (k2->op_flags & OPf_STACKED)
8762                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
8763             {
8764                 warnop = k2->op_type;
8765             }
8766             break;
8767 
8768         case OP_SASSIGN:
8769             if (k1->op_type == OP_READDIR
8770                   || k1->op_type == OP_GLOB
8771                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
8772                  || k1->op_type == OP_EACH
8773                  || k1->op_type == OP_AEACH)
8774             {
8775                 warnop = ((k1->op_type == OP_NULL)
8776                           ? (OPCODE)k1->op_targ : k1->op_type);
8777             }
8778             break;
8779         }
8780         if (warnop) {
8781             const line_t oldline = CopLINE(PL_curcop);
8782             /* This ensures that warnings are reported at the first line
8783                of the construction, not the last.  */
8784             CopLINE_set(PL_curcop, PL_parser->copline);
8785             Perl_warner(aTHX_ packWARN(WARN_MISC),
8786                  "Value of %s%s can be \"0\"; test with defined()",
8787                  PL_op_desc[warnop],
8788                  ((warnop == OP_READLINE || warnop == OP_GLOB)
8789                   ? " construct" : "() operator"));
8790             CopLINE_set(PL_curcop, oldline);
8791         }
8792     }
8793 
8794     /* optimize AND and OR ops that have NOTs as children */
8795     if (first->op_type == OP_NOT
8796         && (first->op_flags & OPf_KIDS)
8797         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
8798             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
8799         ) {
8800         if (type == OP_AND || type == OP_OR) {
8801             if (type == OP_AND)
8802                 type = OP_OR;
8803             else
8804                 type = OP_AND;
8805             op_null(first);
8806             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
8807                 op_null(other);
8808                 prepend_not = 1; /* prepend a NOT op later */
8809             }
8810         }
8811     }
8812 
8813     logop = alloc_LOGOP(type, first, LINKLIST(other));
8814     logop->op_flags |= (U8)flags;
8815     logop->op_private = (U8)(1 | (flags >> 8));
8816 
8817     /* establish postfix order */
8818     logop->op_next = LINKLIST(first);
8819     first->op_next = (OP*)logop;
8820     assert(!OpHAS_SIBLING(first));
8821     op_sibling_splice((OP*)logop, first, 0, other);
8822 
8823     CHECKOP(type,logop);
8824 
8825     o = newUNOP(prepend_not ? OP_NOT : OP_NULL,
8826                 PL_opargs[type] & OA_RETSCALAR ? OPf_WANT_SCALAR : 0,
8827                 (OP*)logop);
8828     other->op_next = o;
8829 
8830     return o;
8831 }
8832 
8833 /*
8834 =for apidoc newCONDOP
8835 
8836 Constructs, checks, and returns a conditional-expression (C<cond_expr>)
8837 op.  C<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
8838 will be set automatically, and, shifted up eight bits, the eight bits of
8839 C<op_private>, except that the bit with value 1 is automatically set.
8840 C<first> supplies the expression selecting between the two branches,
8841 and C<trueop> and C<falseop> supply the branches; they are consumed by
8842 this function and become part of the constructed op tree.
8843 
8844 =cut
8845 */
8846 
8847 OP *
Perl_newCONDOP(pTHX_ I32 flags,OP * first,OP * trueop,OP * falseop)8848 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
8849 {
8850     LOGOP *logop;
8851     OP *start;
8852     OP *o;
8853     OP *cstop;
8854 
8855     PERL_ARGS_ASSERT_NEWCONDOP;
8856 
8857     if (!falseop)
8858         return newLOGOP(OP_AND, 0, first, trueop);
8859     if (!trueop)
8860         return newLOGOP(OP_OR, 0, first, falseop);
8861 
8862     scalarboolean(first);
8863     if ((cstop = search_const(first))) {
8864         /* Left or right arm of the conditional?  */
8865         const bool left = SvTRUE(cSVOPx(cstop)->op_sv);
8866         OP *live = left ? trueop : falseop;
8867         OP *const dead = left ? falseop : trueop;
8868         if (cstop->op_private & OPpCONST_BARE &&
8869             cstop->op_private & OPpCONST_STRICT) {
8870             no_bareword_allowed(cstop);
8871         }
8872         op_free(first);
8873         op_free(dead);
8874         if (live->op_type == OP_LEAVE)
8875             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
8876         else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
8877               || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
8878             /* Mark the op as being unbindable with =~ */
8879             live->op_flags |= OPf_SPECIAL;
8880         live->op_folded = 1;
8881         return live;
8882     }
8883     logop = alloc_LOGOP(OP_COND_EXPR, first, LINKLIST(trueop));
8884     logop->op_flags |= (U8)flags;
8885     logop->op_private = (U8)(1 | (flags >> 8));
8886     logop->op_next = LINKLIST(falseop);
8887 
8888     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
8889             logop);
8890 
8891     /* establish postfix order */
8892     start = LINKLIST(first);
8893     first->op_next = (OP*)logop;
8894 
8895     /* make first, trueop, falseop siblings */
8896     op_sibling_splice((OP*)logop, first,  0, trueop);
8897     op_sibling_splice((OP*)logop, trueop, 0, falseop);
8898 
8899     o = newUNOP(OP_NULL, 0, (OP*)logop);
8900 
8901     trueop->op_next = falseop->op_next = o;
8902 
8903     o->op_next = start;
8904     return o;
8905 }
8906 
8907 /*
8908 =for apidoc newTRYCATCHOP
8909 
8910 Constructs and returns a conditional execution statement that implements
8911 the C<try>/C<catch> semantics.  First the op tree in C<tryblock> is executed,
8912 inside a context that traps exceptions.  If an exception occurs then the
8913 optree in C<catchblock> is executed, with the trapped exception set into the
8914 lexical variable given by C<catchvar> (which must be an op of type
8915 C<OP_PADSV>).  All the optrees are consumed by this function and become part
8916 of the returned op tree.
8917 
8918 The C<flags> argument is currently ignored.
8919 
8920 =cut
8921  */
8922 
8923 OP *
Perl_newTRYCATCHOP(pTHX_ I32 flags,OP * tryblock,OP * catchvar,OP * catchblock)8924 Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock)
8925 {
8926     OP *o, *catchop;
8927 
8928     PERL_ARGS_ASSERT_NEWTRYCATCHOP;
8929     assert(catchvar->op_type == OP_PADSV);
8930 
8931     PERL_UNUSED_ARG(flags);
8932 
8933     /* The returned optree is shaped as:
8934      *   LISTOP leavetrycatch
8935      *       LOGOP entertrycatch
8936      *       LISTOP poptry
8937      *           $tryblock here
8938      *       LOGOP catch
8939      *           $catchblock here
8940      */
8941 
8942     if(tryblock->op_type != OP_LINESEQ)
8943         tryblock = op_convert_list(OP_LINESEQ, 0, tryblock);
8944     OpTYPE_set(tryblock, OP_POPTRY);
8945 
8946     /* Manually construct a naked LOGOP.
8947      * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL)
8948      * containing the LOGOP we wanted as its op_first */
8949     catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock);
8950     OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock);
8951     OpLASTSIB_set(catchblock, catchop);
8952 
8953     /* Inject the catchvar's pad offset into the OP_CATCH targ */
8954     cLOGOPx(catchop)->op_targ = catchvar->op_targ;
8955     op_free(catchvar);
8956 
8957     /* Build the optree structure */
8958     o = newLISTOP(OP_LIST, 0, tryblock, catchop);
8959     o = op_convert_list(OP_ENTERTRYCATCH, 0, o);
8960 
8961     return o;
8962 }
8963 
8964 /*
8965 =for apidoc newRANGE
8966 
8967 Constructs and returns a C<range> op, with subordinate C<flip> and
8968 C<flop> ops.  C<flags> gives the eight bits of C<op_flags> for the
8969 C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
8970 for both the C<flip> and C<range> ops, except that the bit with value
8971 1 is automatically set.  C<left> and C<right> supply the expressions
8972 controlling the endpoints of the range; they are consumed by this function
8973 and become part of the constructed op tree.
8974 
8975 =cut
8976 */
8977 
8978 OP *
Perl_newRANGE(pTHX_ I32 flags,OP * left,OP * right)8979 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
8980 {
8981     LOGOP *range;
8982     OP *flip;
8983     OP *flop;
8984     OP *leftstart;
8985     OP *o;
8986 
8987     PERL_ARGS_ASSERT_NEWRANGE;
8988 
8989     range = alloc_LOGOP(OP_RANGE, left, LINKLIST(right));
8990     range->op_flags = OPf_KIDS;
8991     leftstart = LINKLIST(left);
8992     range->op_private = (U8)(1 | (flags >> 8));
8993 
8994     /* make left and right siblings */
8995     op_sibling_splice((OP*)range, left, 0, right);
8996 
8997     range->op_next = (OP*)range;
8998     flip = newUNOP(OP_FLIP, flags, (OP*)range);
8999     flop = newUNOP(OP_FLOP, 0, flip);
9000     o = newUNOP(OP_NULL, 0, flop);
9001     LINKLIST(flop);
9002     range->op_next = leftstart;
9003 
9004     left->op_next = flip;
9005     right->op_next = flop;
9006 
9007     range->op_targ =
9008         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
9009     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
9010     flip->op_targ =
9011         pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
9012     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
9013     SvPADTMP_on(PAD_SV(flip->op_targ));
9014 
9015     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9016     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
9017 
9018     /* check barewords before they might be optimized away */
9019     if (flip->op_private && cSVOPx(left)->op_private & OPpCONST_STRICT)
9020         no_bareword_allowed(left);
9021     if (flop->op_private && cSVOPx(right)->op_private & OPpCONST_STRICT)
9022         no_bareword_allowed(right);
9023 
9024     flip->op_next = o;
9025     if (!flip->op_private || !flop->op_private)
9026         LINKLIST(o);		/* blow off optimizer unless constant */
9027 
9028     return o;
9029 }
9030 
9031 /*
9032 =for apidoc newLOOPOP
9033 
9034 Constructs, checks, and returns an op tree expressing a loop.  This is
9035 only a loop in the control flow through the op tree; it does not have
9036 the heavyweight loop structure that allows exiting the loop by C<last>
9037 and suchlike.  C<flags> gives the eight bits of C<op_flags> for the
9038 top-level op, except that some bits will be set automatically as required.
9039 C<expr> supplies the expression controlling loop iteration, and C<block>
9040 supplies the body of the loop; they are consumed by this function and
9041 become part of the constructed op tree.  C<debuggable> is currently
9042 unused and should always be 1.
9043 
9044 =cut
9045 */
9046 
9047 OP *
Perl_newLOOPOP(pTHX_ I32 flags,I32 debuggable,OP * expr,OP * block)9048 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
9049 {
9050     PERL_ARGS_ASSERT_NEWLOOPOP;
9051 
9052     OP* listop;
9053     OP* o;
9054     const bool once = block && block->op_flags & OPf_SPECIAL &&
9055                       block->op_type == OP_NULL;
9056 
9057     PERL_UNUSED_ARG(debuggable);
9058 
9059     if (once && (
9060           (expr->op_type == OP_CONST && !SvTRUE(cSVOPx(expr)->op_sv))
9061        || (  expr->op_type == OP_NOT
9062           && cUNOPx(expr)->op_first->op_type == OP_CONST
9063           && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
9064           )
9065        ))
9066         /* Return the block now, so that S_new_logop does not try to
9067            fold it away. */
9068     {
9069         op_free(expr);
9070         return block;	/* do {} while 0 does once */
9071     }
9072 
9073     if (expr->op_type == OP_READLINE
9074         || expr->op_type == OP_READDIR
9075         || expr->op_type == OP_GLOB
9076         || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9077         || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9078         expr = newUNOP(OP_DEFINED, 0,
9079             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9080     } else if (expr->op_flags & OPf_KIDS) {
9081         const OP * const k1 = cUNOPx(expr)->op_first;
9082         const OP * const k2 = k1 ? OpSIBLING(k1) : NULL;
9083         switch (expr->op_type) {
9084           case OP_NULL:
9085             if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9086                   && (k2->op_flags & OPf_STACKED)
9087                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9088                 expr = newUNOP(OP_DEFINED, 0, expr);
9089             break;
9090 
9091           case OP_SASSIGN:
9092             if (k1 && (k1->op_type == OP_READDIR
9093                   || k1->op_type == OP_GLOB
9094                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9095                   || k1->op_type == OP_EACH
9096                   || k1->op_type == OP_AEACH))
9097                 expr = newUNOP(OP_DEFINED, 0, expr);
9098             break;
9099         }
9100     }
9101 
9102     /* if block is null, the next op_append_elem() would put UNSTACK, a scalar
9103      * op, in listop. This is wrong. [perl #27024] */
9104     if (!block)
9105         block = newOP(OP_NULL, 0);
9106     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
9107     o = new_logop(OP_AND, 0, &expr, &listop);
9108 
9109     if (once) {
9110         ASSUME(listop);
9111     }
9112 
9113     if (listop)
9114         cLISTOPx(listop)->op_last->op_next = LINKLIST(o);
9115 
9116     if (once && o != listop)
9117     {
9118         assert(cUNOPo->op_first->op_type == OP_AND
9119             || cUNOPo->op_first->op_type == OP_OR);
9120         o->op_next = cLOGOPx(cUNOPo->op_first)->op_other;
9121     }
9122 
9123     if (o == listop)
9124         o = newUNOP(OP_NULL, 0, o);	/* or do {} while 1 loses outer block */
9125 
9126     o->op_flags |= flags;
9127     o = op_scope(o);
9128     o->op_flags |= OPf_SPECIAL;	/* suppress cx_popblock() curpm restoration*/
9129     return o;
9130 }
9131 
9132 /*
9133 =for apidoc newWHILEOP
9134 
9135 Constructs, checks, and returns an op tree expressing a C<while> loop.
9136 This is a heavyweight loop, with structure that allows exiting the loop
9137 by C<last> and suchlike.
9138 
9139 C<loop> is an optional preconstructed C<enterloop> op to use in the
9140 loop; if it is null then a suitable op will be constructed automatically.
9141 C<expr> supplies the loop's controlling expression.  C<block> supplies the
9142 main body of the loop, and C<cont> optionally supplies a C<continue> block
9143 that operates as a second half of the body.  All of these optree inputs
9144 are consumed by this function and become part of the constructed op tree.
9145 
9146 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9147 op and, shifted up eight bits, the eight bits of C<op_private> for
9148 the C<leaveloop> op, except that (in both cases) some bits will be set
9149 automatically.  C<debuggable> is currently unused and should always be 1.
9150 C<has_my> can be supplied as true to force the
9151 loop body to be enclosed in its own scope.
9152 
9153 =cut
9154 */
9155 
9156 OP *
Perl_newWHILEOP(pTHX_ I32 flags,I32 debuggable,LOOP * loop,OP * expr,OP * block,OP * cont,I32 has_my)9157 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop,
9158         OP *expr, OP *block, OP *cont, I32 has_my)
9159 {
9160     OP *redo;
9161     OP *next = NULL;
9162     OP *listop;
9163     OP *o;
9164     U8 loopflags = 0;
9165 
9166     PERL_UNUSED_ARG(debuggable);
9167 
9168     if (expr) {
9169         if (expr->op_type == OP_READLINE
9170          || expr->op_type == OP_READDIR
9171          || expr->op_type == OP_GLOB
9172          || expr->op_type == OP_EACH || expr->op_type == OP_AEACH
9173                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
9174             expr = newUNOP(OP_DEFINED, 0,
9175                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
9176         } else if (expr->op_flags & OPf_KIDS) {
9177             const OP * const k1 = cUNOPx(expr)->op_first;
9178             const OP * const k2 = (k1) ? OpSIBLING(k1) : NULL;
9179             switch (expr->op_type) {
9180               case OP_NULL:
9181                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
9182                       && (k2->op_flags & OPf_STACKED)
9183                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
9184                     expr = newUNOP(OP_DEFINED, 0, expr);
9185                 break;
9186 
9187               case OP_SASSIGN:
9188                 if (k1 && (k1->op_type == OP_READDIR
9189                       || k1->op_type == OP_GLOB
9190                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
9191                      || k1->op_type == OP_EACH
9192                      || k1->op_type == OP_AEACH))
9193                     expr = newUNOP(OP_DEFINED, 0, expr);
9194                 break;
9195             }
9196         }
9197     }
9198 
9199     if (!block)
9200         block = newOP(OP_NULL, 0);
9201     else if (cont || has_my) {
9202         block = op_scope(block);
9203     }
9204 
9205     if (cont) {
9206         next = LINKLIST(cont);
9207     }
9208     if (expr) {
9209         OP * const unstack = newOP(OP_UNSTACK, 0);
9210         if (!next)
9211             next = unstack;
9212         cont = op_append_elem(OP_LINESEQ, cont, unstack);
9213     }
9214 
9215     assert(block);
9216     listop = op_append_list(OP_LINESEQ, block, cont);
9217     assert(listop);
9218     redo = LINKLIST(listop);
9219 
9220     if (expr) {
9221         scalar(listop);
9222         o = new_logop(OP_AND, 0, &expr, &listop);
9223         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
9224             op_free((OP*)loop);
9225             return expr;		/* listop already freed by new_logop */
9226         }
9227         if (listop)
9228             cLISTOPx(listop)->op_last->op_next =
9229                 (o == listop ? redo : LINKLIST(o));
9230     }
9231     else
9232         o = listop;
9233 
9234     if (!loop) {
9235         NewOp(1101,loop,1,LOOP);
9236         OpTYPE_set(loop, OP_ENTERLOOP);
9237         loop->op_private = 0;
9238         loop->op_next = (OP*)loop;
9239     }
9240 
9241     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
9242 
9243     loop->op_redoop = redo;
9244     loop->op_lastop = o;
9245     o->op_private |= loopflags;
9246 
9247     if (next)
9248         loop->op_nextop = next;
9249     else
9250         loop->op_nextop = o;
9251 
9252     o->op_flags |= flags;
9253     o->op_private |= (flags >> 8);
9254     return o;
9255 }
9256 
9257 /*
9258 =for apidoc newFOROP
9259 
9260 Constructs, checks, and returns an op tree expressing a C<foreach>
9261 loop (iteration through a list of values).  This is a heavyweight loop,
9262 with structure that allows exiting the loop by C<last> and suchlike.
9263 
9264 C<sv> optionally supplies the variable(s) that will be aliased to each
9265 item in turn; if null, it defaults to C<$_>.
9266 C<expr> supplies the list of values to iterate over.  C<block> supplies
9267 the main body of the loop, and C<cont> optionally supplies a C<continue>
9268 block that operates as a second half of the body.  All of these optree
9269 inputs are consumed by this function and become part of the constructed
9270 op tree.
9271 
9272 C<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
9273 op and, shifted up eight bits, the eight bits of C<op_private> for
9274 the C<leaveloop> op, except that (in both cases) some bits will be set
9275 automatically.
9276 
9277 =cut
9278 */
9279 
9280 OP *
Perl_newFOROP(pTHX_ I32 flags,OP * sv,OP * expr,OP * block,OP * cont)9281 Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
9282 {
9283     LOOP *loop;
9284     OP *iter;
9285     PADOFFSET padoff = 0;
9286     PADOFFSET how_many_more = 0;
9287     I32 iterflags = 0;
9288     I32 iterpflags = 0;
9289     bool parens = 0;
9290 
9291     PERL_ARGS_ASSERT_NEWFOROP;
9292 
9293     if (sv) {
9294         if (sv->op_type == OP_RV2SV) {	/* symbol table variable */
9295             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
9296             OpTYPE_set(sv, OP_RV2GV);
9297 
9298             /* The op_type check is needed to prevent a possible segfault
9299              * if the loop variable is undeclared and 'strict vars' is in
9300              * effect. This is illegal but is nonetheless parsed, so we
9301              * may reach this point with an OP_CONST where we're expecting
9302              * an OP_GV.
9303              */
9304             if (cUNOPx(sv)->op_first->op_type == OP_GV
9305              && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
9306                 iterpflags |= OPpITER_DEF;
9307         }
9308         else if (sv->op_type == OP_PADSV) { /* private variable */
9309             if (sv->op_flags & OPf_PARENS) {
9310                 /* handle degenerate 1-var form of "for my ($x, ...)" */
9311                 sv->op_private |= OPpLVAL_INTRO;
9312                 parens = 1;
9313             }
9314             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
9315             padoff = sv->op_targ;
9316             sv->op_targ = 0;
9317             op_free(sv);
9318             sv = NULL;
9319             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9320         }
9321         else if (sv->op_type == OP_NULL && sv->op_targ == OP_SREFGEN)
9322             NOOP;
9323         else if (sv->op_type == OP_LIST) {
9324             LISTOP *list = cLISTOPx(sv);
9325             OP *pushmark = list->op_first;
9326             OP *first_padsv;
9327             UNOP *padsv;
9328             PADOFFSET i;
9329 
9330             iterpflags = OPpLVAL_INTRO; /* for my ($k, $v) () */
9331             parens = 1;
9332 
9333             if (!pushmark || pushmark->op_type != OP_PUSHMARK) {
9334                 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting pushmark",
9335                            pushmark ? PL_op_desc[pushmark->op_type] : "NULL");
9336             }
9337             first_padsv = OpSIBLING(pushmark);
9338             if (!first_padsv || first_padsv->op_type != OP_PADSV) {
9339                 Perl_croak(aTHX_ "panic: newFORLOOP, found %s, expecting padsv",
9340                            first_padsv ? PL_op_desc[first_padsv->op_type] : "NULL");
9341             }
9342             padoff = first_padsv->op_targ;
9343 
9344             /* There should be at least one more PADSV to find, and the ops
9345                should have consecutive values in targ: */
9346             padsv = cUNOPx(OpSIBLING(first_padsv));
9347             do {
9348                 if (!padsv || padsv->op_type != OP_PADSV) {
9349                     Perl_croak(aTHX_ "panic: newFORLOOP, found %s at %zd, expecting padsv",
9350                                padsv ? PL_op_desc[padsv->op_type] : "NULL",
9351                                how_many_more);
9352                 }
9353                 ++how_many_more;
9354                 if (padsv->op_targ != padoff + how_many_more) {
9355                     Perl_croak(aTHX_ "panic: newFORLOOP, padsv at %zd targ is %zd, not %zd",
9356                                how_many_more, padsv->op_targ, padoff + how_many_more);
9357                 }
9358 
9359                 padsv = cUNOPx(OpSIBLING(padsv));
9360             } while (padsv);
9361 
9362             /* OK, this optree has the shape that we expected. So now *we*
9363                "claim" the Pad slots: */
9364             first_padsv->op_targ = 0;
9365             PAD_COMPNAME_GEN_set(padoff, PERL_INT_MAX);
9366 
9367             i = padoff;
9368 
9369             padsv = cUNOPx(OpSIBLING(first_padsv));
9370             do {
9371                 ++i;
9372                 padsv->op_targ = 0;
9373                 PAD_COMPNAME_GEN_set(i, PERL_INT_MAX);
9374 
9375                 padsv = cUNOPx(OpSIBLING(padsv));
9376             } while (padsv);
9377 
9378             op_free(sv);
9379             sv = NULL;
9380         }
9381         else
9382             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
9383         if (padoff) {
9384             PADNAME * const pn = PAD_COMPNAME(padoff);
9385             const char * const name = PadnamePV(pn);
9386 
9387             if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
9388                 iterpflags |= OPpITER_DEF;
9389         }
9390     }
9391     else {
9392         sv = newGVOP(OP_GV, 0, PL_defgv);
9393         iterpflags |= OPpITER_DEF;
9394     }
9395 
9396     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
9397         expr = op_lvalue(op_force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
9398         iterflags |= OPf_STACKED;
9399     }
9400     else if (expr->op_type == OP_NULL &&
9401              (expr->op_flags & OPf_KIDS) &&
9402              cBINOPx(expr)->op_first->op_type == OP_FLOP)
9403     {
9404         /* Basically turn for($x..$y) into the same as for($x,$y), but we
9405          * set the STACKED flag to indicate that these values are to be
9406          * treated as min/max values by 'pp_enteriter'.
9407          */
9408         const UNOP* const flip = cUNOPx(cUNOPx(cBINOPx(expr)->op_first)->op_first);
9409         LOGOP* const range = cLOGOPx(flip->op_first);
9410         OP* const left  = range->op_first;
9411         OP* const right = OpSIBLING(left);
9412         LISTOP* listop;
9413 
9414         range->op_flags &= ~OPf_KIDS;
9415         /* detach range's children */
9416         op_sibling_splice((OP*)range, NULL, -1, NULL);
9417 
9418         listop = cLISTOPx(newLISTOP(OP_LIST, 0, left, right));
9419         listop->op_first->op_next = range->op_next;
9420         left->op_next = range->op_other;
9421         right->op_next = (OP*)listop;
9422         listop->op_next = listop->op_first;
9423 
9424         op_free(expr);
9425         expr = (OP*)(listop);
9426         op_null(expr);
9427         iterflags |= OPf_STACKED;
9428     }
9429     else {
9430         expr = op_lvalue(op_force_list(expr), OP_GREPSTART);
9431     }
9432 
9433     loop = (LOOP*)op_convert_list(OP_ENTERITER, iterflags,
9434                                   op_append_elem(OP_LIST, list(expr),
9435                                                  scalar(sv)));
9436     assert(!loop->op_next);
9437     /* for my  $x () sets OPpLVAL_INTRO;
9438      * for our $x () sets OPpOUR_INTRO */
9439     loop->op_private = (U8)iterpflags;
9440 
9441     /* upgrade loop from a LISTOP to a LOOPOP;
9442      * keep it in-place if there's space */
9443     if (loop->op_slabbed
9444         &&    OpSLOT(loop)->opslot_size
9445             < SIZE_TO_PSIZE(sizeof(LOOP) + OPSLOT_HEADER))
9446     {
9447         /* no space; allocate new op */
9448         LOOP *tmp;
9449         NewOp(1234,tmp,1,LOOP);
9450         Copy(loop,tmp,1,LISTOP);
9451         assert(loop->op_last->op_sibparent == (OP*)loop);
9452         OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
9453         S_op_destroy(aTHX_ (OP*)loop);
9454         loop = tmp;
9455     }
9456     else if (!loop->op_slabbed)
9457     {
9458         /* loop was malloc()ed */
9459         loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
9460         OpLASTSIB_set(loop->op_last, (OP*)loop);
9461     }
9462     loop->op_targ = padoff;
9463     if (parens)
9464         /* hint to deparser that this:  for my (...) ... */
9465         loop->op_flags |= OPf_PARENS;
9466     iter = newOP(OP_ITER, 0);
9467     iter->op_targ = how_many_more;
9468     return newWHILEOP(flags, 1, loop, iter, block, cont, 0);
9469 }
9470 
9471 /*
9472 =for apidoc newLOOPEX
9473 
9474 Constructs, checks, and returns a loop-exiting op (such as C<goto>
9475 or C<last>).  C<type> is the opcode.  C<label> supplies the parameter
9476 determining the target of the op; it is consumed by this function and
9477 becomes part of the constructed op tree.
9478 
9479 =cut
9480 */
9481 
9482 OP*
Perl_newLOOPEX(pTHX_ I32 type,OP * label)9483 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
9484 {
9485     OP *o = NULL;
9486 
9487     PERL_ARGS_ASSERT_NEWLOOPEX;
9488 
9489     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
9490         || type == OP_CUSTOM);
9491 
9492     if (type != OP_GOTO) {
9493         /* "last()" means "last" */
9494         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
9495             o = newOP(type, OPf_SPECIAL);
9496         }
9497     }
9498     else {
9499         /* Check whether it's going to be a goto &function */
9500         if (label->op_type == OP_ENTERSUB
9501                 && !(label->op_flags & OPf_STACKED))
9502             label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
9503     }
9504 
9505     /* Check for a constant argument */
9506     if (label->op_type == OP_CONST) {
9507             SV * const sv = cSVOPx(label)->op_sv;
9508             STRLEN l;
9509             const char *s = SvPV_const(sv,l);
9510             if (l == strlen(s)) {
9511                 o = newPVOP(type,
9512                             SvUTF8(cSVOPx(label)->op_sv),
9513                             savesharedpv(
9514                                 SvPV_nolen_const(cSVOPx(label)->op_sv)));
9515             }
9516     }
9517 
9518     /* If we have already created an op, we do not need the label. */
9519     if (o)
9520                 op_free(label);
9521     else o = newUNOP(type, OPf_STACKED, label);
9522 
9523     PL_hints |= HINT_BLOCK_SCOPE;
9524     return o;
9525 }
9526 
9527 /* if the condition is a literal array or hash
9528    (or @{ ... } etc), make a reference to it.
9529  */
9530 STATIC OP *
S_ref_array_or_hash(pTHX_ OP * cond)9531 S_ref_array_or_hash(pTHX_ OP *cond)
9532 {
9533     if (cond
9534     && (cond->op_type == OP_RV2AV
9535     ||  cond->op_type == OP_PADAV
9536     ||  cond->op_type == OP_RV2HV
9537     ||  cond->op_type == OP_PADHV))
9538 
9539         return newUNOP(OP_REFGEN, 0, op_lvalue(cond, OP_REFGEN));
9540 
9541     else if(cond
9542     && (cond->op_type == OP_ASLICE
9543     ||  cond->op_type == OP_KVASLICE
9544     ||  cond->op_type == OP_HSLICE
9545     ||  cond->op_type == OP_KVHSLICE)) {
9546 
9547         /* anonlist now needs a list from this op, was previously used in
9548          * scalar context */
9549         cond->op_flags &= ~(OPf_WANT_SCALAR | OPf_REF);
9550         cond->op_flags |= OPf_WANT_LIST;
9551 
9552         return newANONLIST(op_lvalue(cond, OP_ANONLIST));
9553     }
9554 
9555     else
9556         return cond;
9557 }
9558 
9559 /* These construct the optree fragments representing given()
9560    and when() blocks.
9561 
9562    entergiven and enterwhen are LOGOPs; the op_other pointer
9563    points up to the associated leave op. We need this so we
9564    can put it in the context and make break/continue work.
9565    (Also, of course, pp_enterwhen will jump straight to
9566    op_other if the match fails.)
9567  */
9568 
9569 STATIC OP *
S_newGIVWHENOP(pTHX_ OP * cond,OP * block,I32 enter_opcode,I32 leave_opcode,PADOFFSET entertarg)9570 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
9571                    I32 enter_opcode, I32 leave_opcode,
9572                    PADOFFSET entertarg)
9573 {
9574     LOGOP *enterop;
9575     OP *o;
9576 
9577     PERL_ARGS_ASSERT_NEWGIVWHENOP;
9578     PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */
9579 
9580     enterop = alloc_LOGOP(enter_opcode, block, NULL);
9581     enterop->op_targ = 0;
9582     enterop->op_private = 0;
9583 
9584     o = newUNOP(leave_opcode, 0, (OP *) enterop);
9585 
9586     if (cond) {
9587         /* prepend cond if we have one */
9588         op_sibling_splice((OP*)enterop, NULL, 0, scalar(cond));
9589 
9590         o->op_next = LINKLIST(cond);
9591         cond->op_next = (OP *) enterop;
9592     }
9593     else {
9594         /* This is a default {} block */
9595         enterop->op_flags |= OPf_SPECIAL;
9596         o      ->op_flags |= OPf_SPECIAL;
9597 
9598         o->op_next = (OP *) enterop;
9599     }
9600 
9601     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
9602                                        entergiven and enterwhen both
9603                                        use ck_null() */
9604 
9605     enterop->op_next = LINKLIST(block);
9606     block->op_next = enterop->op_other = o;
9607 
9608     return o;
9609 }
9610 
9611 
9612 /* For the purposes of 'when(implied_smartmatch)'
9613  *              versus 'when(boolean_expression)',
9614  * does this look like a boolean operation? For these purposes
9615    a boolean operation is:
9616      - a subroutine call [*]
9617      - a logical connective
9618      - a comparison operator
9619      - a filetest operator, with the exception of -s -M -A -C
9620      - defined(), exists() or eof()
9621      - /$re/ or $foo =~ /$re/
9622 
9623    [*] possibly surprising
9624  */
9625 STATIC bool
S_looks_like_bool(pTHX_ const OP * o)9626 S_looks_like_bool(pTHX_ const OP *o)
9627 {
9628     PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
9629 
9630     switch(o->op_type) {
9631         case OP_OR:
9632         case OP_DOR:
9633             return looks_like_bool(cLOGOPo->op_first);
9634 
9635         case OP_AND:
9636         {
9637             OP* sibl = OpSIBLING(cLOGOPo->op_first);
9638             ASSUME(sibl);
9639             return (
9640                 looks_like_bool(cLOGOPo->op_first)
9641              && looks_like_bool(sibl));
9642         }
9643 
9644         case OP_NULL:
9645         case OP_SCALAR:
9646             return (
9647                 o->op_flags & OPf_KIDS
9648             && looks_like_bool(cUNOPo->op_first));
9649 
9650         case OP_ENTERSUB:
9651 
9652         case OP_NOT:	case OP_XOR:
9653 
9654         case OP_EQ:	case OP_NE:	case OP_LT:
9655         case OP_GT:	case OP_LE:	case OP_GE:
9656 
9657         case OP_I_EQ:	case OP_I_NE:	case OP_I_LT:
9658         case OP_I_GT:	case OP_I_LE:	case OP_I_GE:
9659 
9660         case OP_SEQ:	case OP_SNE:	case OP_SLT:
9661         case OP_SGT:	case OP_SLE:	case OP_SGE:
9662 
9663         case OP_SMARTMATCH:
9664 
9665         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
9666         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
9667         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
9668         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
9669         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
9670         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
9671         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
9672         case OP_FTTEXT:   case OP_FTBINARY:
9673 
9674         case OP_DEFINED: case OP_EXISTS:
9675         case OP_MATCH:	 case OP_EOF:
9676 
9677         case OP_FLOP:
9678 
9679             return TRUE;
9680 
9681         case OP_INDEX:
9682         case OP_RINDEX:
9683             /* optimised-away (index() != -1) or similar comparison */
9684             if (o->op_private & OPpTRUEBOOL)
9685                 return TRUE;
9686             return FALSE;
9687 
9688         case OP_CONST:
9689             /* Detect comparisons that have been optimized away */
9690             if (cSVOPo->op_sv == &PL_sv_yes
9691             ||  cSVOPo->op_sv == &PL_sv_no)
9692 
9693                 return TRUE;
9694             else
9695                 return FALSE;
9696         /* FALLTHROUGH */
9697         default:
9698             return FALSE;
9699     }
9700 }
9701 
9702 
9703 /*
9704 =for apidoc newGIVENOP
9705 
9706 Constructs, checks, and returns an op tree expressing a C<given> block.
9707 C<cond> supplies the expression to whose value C<$_> will be locally
9708 aliased, and C<block> supplies the body of the C<given> construct; they
9709 are consumed by this function and become part of the constructed op tree.
9710 C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
9711 
9712 =cut
9713 */
9714 
9715 OP *
Perl_newGIVENOP(pTHX_ OP * cond,OP * block,PADOFFSET defsv_off)9716 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
9717 {
9718     PERL_ARGS_ASSERT_NEWGIVENOP;
9719     PERL_UNUSED_ARG(defsv_off);
9720 
9721     assert(!defsv_off);
9722     return newGIVWHENOP(
9723         ref_array_or_hash(cond),
9724         block,
9725         OP_ENTERGIVEN, OP_LEAVEGIVEN,
9726         0);
9727 }
9728 
9729 /*
9730 =for apidoc newWHENOP
9731 
9732 Constructs, checks, and returns an op tree expressing a C<when> block.
9733 C<cond> supplies the test expression, and C<block> supplies the block
9734 that will be executed if the test evaluates to true; they are consumed
9735 by this function and become part of the constructed op tree.  C<cond>
9736 will be interpreted DWIMically, often as a comparison against C<$_>,
9737 and may be null to generate a C<default> block.
9738 
9739 =cut
9740 */
9741 
9742 OP *
Perl_newWHENOP(pTHX_ OP * cond,OP * block)9743 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
9744 {
9745     const bool cond_llb = (!cond || looks_like_bool(cond));
9746     OP *cond_op;
9747 
9748     PERL_ARGS_ASSERT_NEWWHENOP;
9749 
9750     if (cond_llb)
9751         cond_op = cond;
9752     else {
9753         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
9754                 newDEFSVOP(),
9755                 scalar(ref_array_or_hash(cond)));
9756     }
9757 
9758     return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
9759 }
9760 
9761 /*
9762 =for apidoc newDEFEROP
9763 
9764 Constructs and returns a deferred-block statement that implements the
9765 C<defer> semantics.  The C<block> optree is consumed by this function and
9766 becomes part of the returned optree.
9767 
9768 The C<flags> argument carries additional flags to set on the returned op,
9769 including the C<op_private> field.
9770 
9771 =cut
9772  */
9773 
9774 OP *
Perl_newDEFEROP(pTHX_ I32 flags,OP * block)9775 Perl_newDEFEROP(pTHX_ I32 flags, OP *block)
9776 {
9777     OP *o, *start, *blockfirst;
9778 
9779     PERL_ARGS_ASSERT_NEWDEFEROP;
9780 
9781     forbid_outofblock_ops(block,
9782         (flags & (OPpDEFER_FINALLY << 8)) ? "a \"finally\" block" : "a \"defer\" block");
9783 
9784     start = LINKLIST(block);
9785 
9786     /* Hide the block inside an OP_NULL with no execution */
9787     block = newUNOP(OP_NULL, 0, block);
9788     block->op_next = block;
9789 
9790     o = (OP *)alloc_LOGOP(OP_PUSHDEFER, block, start);
9791     o->op_flags |= OPf_WANT_VOID | (U8)(flags);
9792     o->op_private = (U8)(flags >> 8);
9793 
9794     /* Terminate the block */
9795     blockfirst = cUNOPx(block)->op_first;
9796     assert(blockfirst->op_type == OP_SCOPE || blockfirst->op_type == OP_LEAVE);
9797     blockfirst->op_next = NULL;
9798 
9799     return o;
9800 }
9801 
9802 /*
9803 =for apidoc op_wrap_finally
9804 
9805 Wraps the given C<block> optree fragment in its own scoped block, arranging
9806 for the C<finally> optree fragment to be invoked when leaving that block for
9807 any reason. Both optree fragments are consumed and the combined result is
9808 returned.
9809 
9810 =cut
9811 */
9812 
9813 OP *
Perl_op_wrap_finally(pTHX_ OP * block,OP * finally)9814 Perl_op_wrap_finally(pTHX_ OP *block, OP *finally)
9815 {
9816     PERL_ARGS_ASSERT_OP_WRAP_FINALLY;
9817 
9818     /* TODO: If block is already an ENTER/LEAVE-wrapped line sequence we can
9819      * just splice the DEFEROP in at the top, for efficiency.
9820      */
9821 
9822     OP *o = newLISTOP(OP_LINESEQ, 0, newDEFEROP((OPpDEFER_FINALLY << 8), finally), block);
9823     o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
9824     OpTYPE_set(o, OP_LEAVE);
9825 
9826     return o;
9827 }
9828 
9829 /* must not conflict with SVf_UTF8 */
9830 #define CV_CKPROTO_CURSTASH	0x1
9831 
9832 void
Perl_cv_ckproto_len_flags(pTHX_ const CV * cv,const GV * gv,const char * p,const STRLEN len,const U32 flags)9833 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
9834                     const STRLEN len, const U32 flags)
9835 {
9836     SV *name = NULL, *msg;
9837     const char * cvp = SvROK(cv)
9838                         ? SvTYPE(SvRV_const(cv)) == SVt_PVCV
9839                            ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv))
9840                            : ""
9841                         : CvPROTO(cv);
9842     STRLEN clen = CvPROTOLEN(cv), plen = len;
9843 
9844     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
9845 
9846     if (p == NULL && cvp == NULL)
9847         return;
9848 
9849     if (!ckWARN_d(WARN_PROTOTYPE))
9850         return;
9851 
9852     if (p && cvp) {
9853         p = S_strip_spaces(aTHX_ p, &plen);
9854         cvp = S_strip_spaces(aTHX_ cvp, &clen);
9855         if ((flags & SVf_UTF8) == SvUTF8(cv)) {
9856             if (plen == clen && memEQ(cvp, p, plen))
9857                 return;
9858         } else {
9859             if (flags & SVf_UTF8) {
9860                 if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
9861                     return;
9862             }
9863             else {
9864                 if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
9865                     return;
9866             }
9867         }
9868     }
9869 
9870     msg = sv_newmortal();
9871 
9872     if (gv)
9873     {
9874         if (isGV(gv))
9875             gv_efullname3(name = sv_newmortal(), gv, NULL);
9876         else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
9877             name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
9878         else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) {
9879             name = newSVhek_mortal(HvNAME_HEK(PL_curstash));
9880             sv_catpvs(name, "::");
9881             if (SvROK(gv)) {
9882                 assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV);
9883                 assert (CvNAMED(SvRV_const(gv)));
9884                 sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv))));
9885             }
9886             else sv_catsv(name, (SV *)gv);
9887         }
9888         else name = (SV *)gv;
9889     }
9890     sv_setpvs(msg, "Prototype mismatch:");
9891     if (name)
9892         Perl_sv_catpvf(aTHX_ msg, " sub %" SVf, SVfARG(name));
9893     if (cvp)
9894         Perl_sv_catpvf(aTHX_ msg, " (%" UTF8f ")",
9895             UTF8fARG(SvUTF8(cv),clen,cvp)
9896         );
9897     else
9898         sv_catpvs(msg, ": none");
9899     sv_catpvs(msg, " vs ");
9900     if (p)
9901         Perl_sv_catpvf(aTHX_ msg, "(%" UTF8f ")", UTF8fARG(flags & SVf_UTF8,len,p));
9902     else
9903         sv_catpvs(msg, "none");
9904     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%" SVf, SVfARG(msg));
9905 }
9906 
9907 static void const_sv_xsub(pTHX_ CV* cv);
9908 static void const_av_xsub(pTHX_ CV* cv);
9909 
9910 /*
9911 
9912 =for apidoc_section $optree_manipulation
9913 
9914 =for apidoc cv_const_sv
9915 
9916 If C<cv> is a constant sub eligible for inlining, returns the constant
9917 value returned by the sub.  Otherwise, returns C<NULL>.
9918 
9919 Constant subs can be created with C<newCONSTSUB> or as described in
9920 L<perlsub/"Constant Functions">.
9921 
9922 =cut
9923 */
9924 SV *
Perl_cv_const_sv(const CV * const cv)9925 Perl_cv_const_sv(const CV *const cv)
9926 {
9927     SV *sv;
9928     if (!cv)
9929         return NULL;
9930     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
9931         return NULL;
9932     sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9933     if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
9934     return sv;
9935 }
9936 
9937 SV *
Perl_cv_const_sv_or_av(const CV * const cv)9938 Perl_cv_const_sv_or_av(const CV * const cv)
9939 {
9940     if (!cv)
9941         return NULL;
9942     if (SvROK(cv)) return SvRV((SV *)cv);
9943     assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
9944     return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
9945 }
9946 
9947 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
9948  * Can be called in 2 ways:
9949  *
9950  * !allow_lex
9951  * 	look for a single OP_CONST with attached value: return the value
9952  *
9953  * allow_lex && !CvCONST(cv);
9954  *
9955  * 	examine the clone prototype, and if contains only a single
9956  * 	OP_CONST, return the value; or if it contains a single PADSV ref-
9957  * 	erencing an outer lexical, turn on CvCONST to indicate the CV is
9958  * 	a candidate for "constizing" at clone time, and return NULL.
9959  */
9960 
9961 static SV *
S_op_const_sv(pTHX_ const OP * o,CV * cv,bool allow_lex)9962 S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
9963 {
9964     SV *sv = NULL;
9965     bool padsv = FALSE;
9966 
9967     assert(o);
9968     assert(cv);
9969 
9970     for (; o; o = o->op_next) {
9971         const OPCODE type = o->op_type;
9972 
9973         if (type == OP_NEXTSTATE || type == OP_LINESEQ
9974              || type == OP_NULL
9975              || type == OP_PUSHMARK)
9976                 continue;
9977         if (type == OP_DBSTATE)
9978                 continue;
9979         if (type == OP_LEAVESUB)
9980             break;
9981         if (sv)
9982             return NULL;
9983         if (type == OP_CONST && cSVOPo->op_sv)
9984             sv = cSVOPo->op_sv;
9985         else if (type == OP_UNDEF && !o->op_private) {
9986             sv = newSV_type(SVt_NULL);
9987             SAVEFREESV(sv);
9988         }
9989         else if (allow_lex && type == OP_PADSV) {
9990                 if (PAD_COMPNAME_FLAGS(o->op_targ) & PADNAMEf_OUTER)
9991                 {
9992                     sv = &PL_sv_undef; /* an arbitrary non-null value */
9993                     padsv = TRUE;
9994                 }
9995                 else
9996                     return NULL;
9997         }
9998         else {
9999             return NULL;
10000         }
10001     }
10002     if (padsv) {
10003         CvCONST_on(cv);
10004         return NULL;
10005     }
10006     return sv;
10007 }
10008 
10009 static void
S_already_defined(pTHX_ CV * const cv,OP * const block,OP * const o,PADNAME * const name,SV ** const const_svp)10010 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
10011                         PADNAME * const name, SV ** const const_svp)
10012 {
10013     assert (cv);
10014     assert (o || name);
10015     assert (const_svp);
10016     if (!block) {
10017         if (CvFLAGS(PL_compcv)) {
10018             /* might have had built-in attrs applied */
10019             const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
10020             if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
10021              && ckWARN(WARN_MISC))
10022             {
10023                 /* protect against fatal warnings leaking compcv */
10024                 SAVEFREESV(PL_compcv);
10025                 Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
10026                 SvREFCNT_inc_simple_void_NN(PL_compcv);
10027             }
10028             CvFLAGS(cv) |=
10029                 (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
10030                   & ~(CVf_LVALUE * pureperl));
10031         }
10032         return;
10033     }
10034 
10035     /* redundant check for speed: */
10036     if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
10037         const line_t oldline = CopLINE(PL_curcop);
10038         SV *namesv = o
10039             ? cSVOPo->op_sv
10040             : newSVpvn_flags( PadnamePV(name)+1,PadnameLEN(name)-1,
10041                (PadnameUTF8(name)) ? SVf_UTF8|SVs_TEMP : SVs_TEMP
10042               );
10043         if (PL_parser && PL_parser->copline != NOLINE)
10044             /* This ensures that warnings are reported at the first
10045                line of a redefinition, not the last.  */
10046             CopLINE_set(PL_curcop, PL_parser->copline);
10047         /* protect against fatal warnings leaking compcv */
10048         SAVEFREESV(PL_compcv);
10049         report_redefined_cv(namesv, cv, const_svp);
10050         SvREFCNT_inc_simple_void_NN(PL_compcv);
10051         CopLINE_set(PL_curcop, oldline);
10052     }
10053     SAVEFREESV(cv);
10054     return;
10055 }
10056 
10057 CV *
Perl_newMYSUB(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block)10058 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
10059 {
10060     CV **spot;
10061     SV **svspot;
10062     const char *ps;
10063     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10064     U32 ps_utf8 = 0;
10065     CV *cv = NULL;
10066     CV *compcv = PL_compcv;
10067     SV *const_sv;
10068     PADNAME *name;
10069     PADOFFSET pax = o->op_targ;
10070     CV *outcv = CvOUTSIDE(PL_compcv);
10071     CV *clonee = NULL;
10072     HEK *hek = NULL;
10073     bool reusable = FALSE;
10074     OP *start = NULL;
10075 #ifdef PERL_DEBUG_READONLY_OPS
10076     OPSLAB *slab = NULL;
10077 #endif
10078 
10079     PERL_ARGS_ASSERT_NEWMYSUB;
10080 
10081     PL_hints |= HINT_BLOCK_SCOPE;
10082 
10083     /* Find the pad slot for storing the new sub.
10084        We cannot use PL_comppad, as it is the pad owned by the new sub.  We
10085        need to look in CvOUTSIDE and find the pad belonging to the enclos-
10086        ing sub.  And then we need to dig deeper if this is a lexical from
10087        outside, as in:
10088            my sub foo; sub { sub foo { } }
10089      */
10090   redo:
10091     name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
10092     if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
10093         pax = PARENT_PAD_INDEX(name);
10094         outcv = CvOUTSIDE(outcv);
10095         assert(outcv);
10096         goto redo;
10097     }
10098     svspot =
10099         &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
10100                         [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
10101     spot = (CV **)svspot;
10102 
10103     if (!(PL_parser && PL_parser->error_count))
10104         move_proto_attr(&proto, &attrs, (GV *)PadnameSV(name), 0);
10105 
10106     if (proto) {
10107         assert(proto->op_type == OP_CONST);
10108         ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
10109         ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
10110     }
10111     else
10112         ps = NULL;
10113 
10114     if (proto)
10115         SAVEFREEOP(proto);
10116     if (attrs)
10117         SAVEFREEOP(attrs);
10118 
10119     if (PL_parser && PL_parser->error_count) {
10120         op_free(block);
10121         SvREFCNT_dec(PL_compcv);
10122         PL_compcv = 0;
10123         goto done;
10124     }
10125 
10126     if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10127         cv = *spot;
10128         svspot = (SV **)(spot = &clonee);
10129     }
10130     else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
10131         cv = *spot;
10132     else {
10133         assert (SvTYPE(*spot) == SVt_PVCV);
10134         if (CvNAMED(*spot))
10135             hek = CvNAME_HEK(*spot);
10136         else {
10137             U32 hash;
10138             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10139             CvNAME_HEK_set(*spot, hek =
10140                 share_hek(
10141                     PadnamePV(name)+1,
10142                     (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10143                     hash
10144                 )
10145             );
10146             CvLEXICAL_on(*spot);
10147         }
10148         cv = PadnamePROTOCV(name);
10149         svspot = (SV **)(spot = &PadnamePROTOCV(name));
10150     }
10151 
10152     if (block) {
10153         /* This makes sub {}; work as expected.  */
10154         if (block->op_type == OP_STUB) {
10155             const line_t l = PL_parser->copline;
10156             op_free(block);
10157             block = newSTATEOP(0, NULL, 0);
10158             PL_parser->copline = l;
10159         }
10160         block = CvLVALUE(compcv)
10161              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
10162                    ? newUNOP(OP_LEAVESUBLV, 0,
10163                              op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
10164                    : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
10165         start = LINKLIST(block);
10166         block->op_next = 0;
10167         if (ps && !*ps && !attrs && !CvLVALUE(compcv))
10168             const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
10169         else
10170             const_sv = NULL;
10171     }
10172     else
10173         const_sv = NULL;
10174 
10175     if (cv) {
10176         const bool exists = CvROOT(cv) || CvXSUB(cv);
10177 
10178         /* if the subroutine doesn't exist and wasn't pre-declared
10179          * with a prototype, assume it will be AUTOLOADed,
10180          * skipping the prototype check
10181          */
10182         if (exists || SvPOK(cv))
10183             cv_ckproto_len_flags(cv, (GV *)PadnameSV(name), ps, ps_len,
10184                                  ps_utf8);
10185         /* already defined? */
10186         if (exists) {
10187             S_already_defined(aTHX_ cv, block, NULL, name, &const_sv);
10188             if (block)
10189                 cv = NULL;
10190             else {
10191                 if (attrs)
10192                     goto attrs;
10193                 /* just a "sub foo;" when &foo is already defined */
10194                 SAVEFREESV(compcv);
10195                 goto done;
10196             }
10197         }
10198         else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
10199             cv = NULL;
10200             reusable = TRUE;
10201         }
10202     }
10203 
10204     if (const_sv) {
10205         SvREFCNT_inc_simple_void_NN(const_sv);
10206         SvFLAGS(const_sv) |= SVs_PADTMP;
10207         if (cv) {
10208             assert(!CvROOT(cv) && !CvCONST(cv));
10209             cv_forget_slab(cv);
10210         }
10211         else {
10212             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
10213             CvFILE_set_from_cop(cv, PL_curcop);
10214             CvSTASH_set(cv, PL_curstash);
10215             *spot = cv;
10216         }
10217         SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10218         CvXSUBANY(cv).any_ptr = const_sv;
10219         CvXSUB(cv) = const_sv_xsub;
10220         CvCONST_on(cv);
10221         CvISXSUB_on(cv);
10222         PoisonPADLIST(cv);
10223         CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(compcv);
10224         op_free(block);
10225         SvREFCNT_dec(compcv);
10226         PL_compcv = NULL;
10227         goto setname;
10228     }
10229 
10230     /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
10231        determine whether this sub definition is in the same scope as its
10232        declaration.  If this sub definition is inside an inner named pack-
10233        age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
10234        the package sub.  So check PadnameOUTER(name) too.
10235      */
10236     if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
10237         assert(!CvWEAKOUTSIDE(compcv));
10238         SvREFCNT_dec(CvOUTSIDE(compcv));
10239         CvWEAKOUTSIDE_on(compcv);
10240     }
10241     /* XXX else do we have a circular reference? */
10242 
10243     if (cv) {	/* must reuse cv in case stub is referenced elsewhere */
10244         /* transfer PL_compcv to cv */
10245         if (block) {
10246             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10247             cv_flags_t preserved_flags =
10248                 CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
10249             PADLIST *const temp_padl = CvPADLIST(cv);
10250             CV *const temp_cv = CvOUTSIDE(cv);
10251             const cv_flags_t other_flags =
10252                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10253             OP * const cvstart = CvSTART(cv);
10254 
10255             SvPOK_off(cv);
10256             CvFLAGS(cv) =
10257                 CvFLAGS(compcv) | preserved_flags;
10258             CvOUTSIDE(cv) = CvOUTSIDE(compcv);
10259             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
10260             CvPADLIST_set(cv, CvPADLIST(compcv));
10261             CvOUTSIDE(compcv) = temp_cv;
10262             CvPADLIST_set(compcv, temp_padl);
10263             CvSTART(cv) = CvSTART(compcv);
10264             CvSTART(compcv) = cvstart;
10265             CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10266             CvFLAGS(compcv) |= other_flags;
10267 
10268             if (free_file) {
10269                 Safefree(CvFILE(cv));
10270                 CvFILE(cv) = NULL;
10271             }
10272 
10273             /* inner references to compcv must be fixed up ... */
10274             pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
10275             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10276                 ++PL_sub_generation;
10277         }
10278         else {
10279             /* Might have had built-in attributes applied -- propagate them. */
10280             CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
10281         }
10282         /* ... before we throw it away */
10283         SvREFCNT_dec(compcv);
10284         PL_compcv = compcv = cv;
10285     }
10286     else {
10287         cv = compcv;
10288         *spot = cv;
10289     }
10290 
10291   setname:
10292     CvLEXICAL_on(cv);
10293     if (!CvNAME_HEK(cv)) {
10294         if (hek) (void)share_hek_hek(hek);
10295         else {
10296             U32 hash;
10297             PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
10298             hek = share_hek(PadnamePV(name)+1,
10299                       (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
10300                       hash);
10301         }
10302         CvNAME_HEK_set(cv, hek);
10303     }
10304 
10305     if (const_sv)
10306         goto clone;
10307 
10308     if (CvFILE(cv) && CvDYNFILE(cv))
10309         Safefree(CvFILE(cv));
10310     CvFILE_set_from_cop(cv, PL_curcop);
10311     CvSTASH_set(cv, PL_curstash);
10312 
10313     if (ps) {
10314         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10315         if (ps_utf8)
10316             SvUTF8_on(MUTABLE_SV(cv));
10317     }
10318 
10319     if (block) {
10320         /* If we assign an optree to a PVCV, then we've defined a
10321          * subroutine that the debugger could be able to set a breakpoint
10322          * in, so signal to pp_entereval that it should not throw away any
10323          * saved lines at scope exit.  */
10324 
10325         PL_breakable_sub_gen++;
10326         CvROOT(cv) = block;
10327         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10328            itself has a refcount. */
10329         CvSLABBED_off(cv);
10330         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10331 #ifdef PERL_DEBUG_READONLY_OPS
10332         slab = (OPSLAB *)CvSTART(cv);
10333 #endif
10334         S_process_optree(aTHX_ cv, block, start);
10335     }
10336 
10337   attrs:
10338     if (attrs) {
10339         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10340         apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
10341     }
10342 
10343     if (block) {
10344         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10345             SV * const tmpstr = sv_newmortal();
10346             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10347                                                   GV_ADDMULTI, SVt_PVHV);
10348             HV *hv;
10349             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" LINE_Tf "-%" LINE_Tf,
10350                                           CopFILE(PL_curcop),
10351                                           (line_t)PL_subline,
10352                                           CopLINE(PL_curcop));
10353             if (HvNAME_HEK(PL_curstash)) {
10354                 sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
10355                 sv_catpvs(tmpstr, "::");
10356             }
10357             else
10358                 sv_setpvs(tmpstr, "__ANON__::");
10359 
10360             sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
10361                             PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
10362             (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
10363             hv = GvHVn(db_postponed);
10364             if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
10365                 CV * const pcv = GvCV(db_postponed);
10366                 if (pcv) {
10367                     dSP;
10368                     PUSHMARK(SP);
10369                     XPUSHs(tmpstr);
10370                     PUTBACK;
10371                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10372                 }
10373             }
10374         }
10375     }
10376 
10377   clone:
10378     if (clonee) {
10379         assert(CvDEPTH(outcv));
10380         spot = (CV **)
10381             &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
10382         if (reusable)
10383             cv_clone_into(clonee, *spot);
10384         else *spot = cv_clone(clonee);
10385         SvREFCNT_dec_NN(clonee);
10386         cv = *spot;
10387     }
10388 
10389     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
10390         PADOFFSET depth = CvDEPTH(outcv);
10391         while (--depth) {
10392             SV *oldcv;
10393             svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
10394             oldcv = *svspot;
10395             *svspot = SvREFCNT_inc_simple_NN(cv);
10396             SvREFCNT_dec(oldcv);
10397         }
10398     }
10399 
10400   done:
10401     if (PL_parser)
10402         PL_parser->copline = NOLINE;
10403     LEAVE_SCOPE(floor);
10404 #ifdef PERL_DEBUG_READONLY_OPS
10405     if (slab)
10406         Slab_to_ro(slab);
10407 #endif
10408     op_free(o);
10409     return cv;
10410 }
10411 
10412 /*
10413 =for apidoc newATTRSUB_x
10414 
10415 Construct a Perl subroutine, also performing some surrounding jobs.
10416 
10417 This function is expected to be called in a Perl compilation context,
10418 and some aspects of the subroutine are taken from global variables
10419 associated with compilation.  In particular, C<PL_compcv> represents
10420 the subroutine that is currently being compiled.  It must be non-null
10421 when this function is called, and some aspects of the subroutine being
10422 constructed are taken from it.  The constructed subroutine may actually
10423 be a reuse of the C<PL_compcv> object, but will not necessarily be so.
10424 
10425 If C<block> is null then the subroutine will have no body, and for the
10426 time being it will be an error to call it.  This represents a forward
10427 subroutine declaration such as S<C<sub foo ($$);>>.  If C<block> is
10428 non-null then it provides the Perl code of the subroutine body, which
10429 will be executed when the subroutine is called.  This body includes
10430 any argument unwrapping code resulting from a subroutine signature or
10431 similar.  The pad use of the code must correspond to the pad attached
10432 to C<PL_compcv>.  The code is not expected to include a C<leavesub> or
10433 C<leavesublv> op; this function will add such an op.  C<block> is consumed
10434 by this function and will become part of the constructed subroutine.
10435 
10436 C<proto> specifies the subroutine's prototype, unless one is supplied
10437 as an attribute (see below).  If C<proto> is null, then the subroutine
10438 will not have a prototype.  If C<proto> is non-null, it must point to a
10439 C<const> op whose value is a string, and the subroutine will have that
10440 string as its prototype.  If a prototype is supplied as an attribute, the
10441 attribute takes precedence over C<proto>, but in that case C<proto> should
10442 preferably be null.  In any case, C<proto> is consumed by this function.
10443 
10444 C<attrs> supplies attributes to be applied the subroutine.  A handful of
10445 attributes take effect by built-in means, being applied to C<PL_compcv>
10446 immediately when seen.  Other attributes are collected up and attached
10447 to the subroutine by this route.  C<attrs> may be null to supply no
10448 attributes, or point to a C<const> op for a single attribute, or point
10449 to a C<list> op whose children apart from the C<pushmark> are C<const>
10450 ops for one or more attributes.  Each C<const> op must be a string,
10451 giving the attribute name optionally followed by parenthesised arguments,
10452 in the manner in which attributes appear in Perl source.  The attributes
10453 will be applied to the sub by this function.  C<attrs> is consumed by
10454 this function.
10455 
10456 If C<o_is_gv> is false and C<o> is null, then the subroutine will
10457 be anonymous.  If C<o_is_gv> is false and C<o> is non-null, then C<o>
10458 must point to a C<const> OP, which will be consumed by this function,
10459 and its string value supplies a name for the subroutine.  The name may
10460 be qualified or unqualified, and if it is unqualified then a default
10461 stash will be selected in some manner.  If C<o_is_gv> is true, then C<o>
10462 doesn't point to an C<OP> at all, but is instead a cast pointer to a C<GV>
10463 by which the subroutine will be named.
10464 
10465 If there is already a subroutine of the specified name, then the new
10466 sub will either replace the existing one in the glob or be merged with
10467 the existing one.  A warning may be generated about redefinition.
10468 
10469 If the subroutine has one of a few special names, such as C<BEGIN> or
10470 C<END>, then it will be claimed by the appropriate queue for automatic
10471 running of phase-related subroutines.  In this case the relevant glob will
10472 be left not containing any subroutine, even if it did contain one before.
10473 In the case of C<BEGIN>, the subroutine will be executed and the reference
10474 to it disposed of before this function returns.
10475 
10476 The function returns a pointer to the constructed subroutine.  If the sub
10477 is anonymous then ownership of one counted reference to the subroutine
10478 is transferred to the caller.  If the sub is named then the caller does
10479 not get ownership of a reference.  In most such cases, where the sub
10480 has a non-phase name, the sub will be alive at the point it is returned
10481 by virtue of being contained in the glob that names it.  A phase-named
10482 subroutine will usually be alive by virtue of the reference owned by the
10483 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
10484 been executed, will quite likely have been destroyed already by the
10485 time this function returns, making it erroneous for the caller to make
10486 any use of the returned pointer.  It is the caller's responsibility to
10487 ensure that it knows which of these situations applies.
10488 
10489 =for apidoc newATTRSUB
10490 Construct a Perl subroutine, also performing some surrounding jobs.
10491 
10492 This is the same as L<perlintern/C<newATTRSUB_x>> with its C<o_is_gv> parameter set to
10493 FALSE.  This means that if C<o> is null, the new sub will be anonymous; otherwise
10494 the name will be derived from C<o> in the way described (as with all other
10495 details) in L<perlintern/C<newATTRSUB_x>>.
10496 
10497 =for apidoc newSUB
10498 Like C<L</newATTRSUB>>, but without attributes.
10499 
10500 =cut
10501 */
10502 
10503 /* _x = extended */
10504 CV *
Perl_newATTRSUB_x(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block,bool o_is_gv)10505 Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
10506                             OP *block, bool o_is_gv)
10507 {
10508     GV *gv;
10509     const char *ps;
10510     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
10511     U32 ps_utf8 = 0;
10512     CV *cv = NULL;     /* the previous CV with this name, if any */
10513     SV *const_sv;
10514     const bool ec = PL_parser && PL_parser->error_count;
10515     /* If the subroutine has no body, no attributes, and no builtin attributes
10516        then it's just a sub declaration, and we may be able to get away with
10517        storing with a placeholder scalar in the symbol table, rather than a
10518        full CV.  If anything is present then it will take a full CV to
10519        store it.  */
10520     const I32 gv_fetch_flags
10521         = ec ? GV_NOADD_NOINIT :
10522         (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
10523         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
10524     STRLEN namlen = 0;
10525     const char * const name =
10526          o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
10527     bool has_name;
10528     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
10529     bool evanescent = FALSE;
10530     bool isBEGIN = FALSE;
10531     OP *start = NULL;
10532 #ifdef PERL_DEBUG_READONLY_OPS
10533     OPSLAB *slab = NULL;
10534 #endif
10535 
10536     if (o_is_gv) {
10537         gv = (GV*)o;
10538         o = NULL;
10539         has_name = TRUE;
10540     } else if (name) {
10541         /* Try to optimise and avoid creating a GV.  Instead, the CV’s name
10542            hek and CvSTASH pointer together can imply the GV.  If the name
10543            contains a package name, then GvSTASH(CvGV(cv)) may differ from
10544            CvSTASH, so forego the optimisation if we find any.
10545            Also, we may be called from load_module at run time, so
10546            PL_curstash (which sets CvSTASH) may not point to the stash the
10547            sub is stored in.  */
10548         /* XXX This optimization is currently disabled for packages other
10549                than main, since there was too much CPAN breakage.  */
10550         const I32 flags =
10551            ec ? GV_NOADD_NOINIT
10552               :   (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
10553                || PL_curstash != PL_defstash
10554                || memchr(name, ':', namlen) || memchr(name, '\'', namlen)
10555                     ? gv_fetch_flags
10556                     : GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
10557         gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV);
10558         has_name = TRUE;
10559     } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
10560         SV * const sv = sv_newmortal();
10561         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%" LINE_Tf "]",
10562                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
10563                        CopFILE(PL_curcop), CopLINE(PL_curcop));
10564         gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
10565         has_name = TRUE;
10566     } else if (PL_curstash) {
10567         gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
10568         has_name = FALSE;
10569     } else {
10570         gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
10571         has_name = FALSE;
10572     }
10573 
10574     if (!ec) {
10575         if (isGV(gv)) {
10576             move_proto_attr(&proto, &attrs, gv, 0);
10577         } else {
10578             assert(cSVOPo);
10579             move_proto_attr(&proto, &attrs, (GV *)cSVOPo->op_sv, 1);
10580         }
10581     }
10582 
10583     if (o)
10584         SAVEFREEOP(o);
10585     if (proto)
10586         SAVEFREEOP(proto);
10587     if (attrs)
10588         SAVEFREEOP(attrs);
10589 
10590     /* we need this in two places later on, so set it up here */
10591     if (name && block) {
10592         const char *s = (char *) my_memrchr(name, ':', namlen);
10593         s = s ? s+1 : name;
10594         isBEGIN = strEQ(s,"BEGIN");
10595     }
10596 
10597     if (isBEGIN) {
10598         /* Make sure that we do not have any prototypes or
10599          * attributes associated with this BEGIN block, as the block
10600          * is already done and dusted, and we will assert or worse
10601          * if we try to attach the prototype to the now essentially
10602          * nonexistent sub. */
10603         if (proto)
10604             /* diag_listed_as: %s on BEGIN block ignored */
10605             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Prototype on BEGIN block ignored");
10606         if (attrs)
10607             /* diag_listed_as: %s on BEGIN block ignored */
10608             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Attribute on BEGIN block ignored");
10609         proto = NULL;
10610         attrs = NULL;
10611     }
10612 
10613     if (proto) {
10614         assert(proto->op_type == OP_CONST);
10615         ps = SvPV_const(cSVOPx(proto)->op_sv, ps_len);
10616         ps_utf8 = SvUTF8(cSVOPx(proto)->op_sv);
10617     }
10618     else
10619         ps = NULL;
10620 
10621     if (ec) {
10622         op_free(block);
10623 
10624         if (name)
10625             SvREFCNT_dec(PL_compcv);
10626         else
10627             cv = PL_compcv;
10628 
10629         PL_compcv = 0;
10630         if (isBEGIN) {
10631             if (PL_in_eval & EVAL_KEEPERR)
10632                 Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
10633             else {
10634                 SV * const errsv = ERRSV;
10635                 /* force display of errors found but not reported */
10636                 sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
10637                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
10638             }
10639         }
10640         goto done;
10641     }
10642 
10643     if (!block && SvTYPE(gv) != SVt_PVGV) {
10644         /* If we are not defining a new sub and the existing one is not a
10645            full GV + CV... */
10646         if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) {
10647             /* We are applying attributes to an existing sub, so we need it
10648                upgraded if it is a constant.  */
10649             if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)
10650                 gv_init_pvn(gv, PL_curstash, name, namlen,
10651                             SVf_UTF8 * name_is_utf8);
10652         }
10653         else {			/* Maybe prototype now, and had at maximum
10654                                    a prototype or const/sub ref before.  */
10655             if (SvTYPE(gv) > SVt_NULL) {
10656                 cv_ckproto_len_flags((const CV *)gv,
10657                                     o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10658                                     ps_len, ps_utf8);
10659             }
10660 
10661             if (!SvROK(gv)) {
10662                 if (ps) {
10663                     sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
10664                     if (ps_utf8)
10665                         SvUTF8_on(MUTABLE_SV(gv));
10666                 }
10667                 else
10668                     sv_setiv(MUTABLE_SV(gv), -1);
10669             }
10670 
10671             SvREFCNT_dec(PL_compcv);
10672             cv = PL_compcv = NULL;
10673             goto done;
10674         }
10675     }
10676 
10677     cv = (!name || (isGV(gv) && GvCVGEN(gv)))
10678         ? NULL
10679         : isGV(gv)
10680             ? GvCV(gv)
10681             : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
10682                 ? (CV *)SvRV(gv)
10683                 : NULL;
10684 
10685     if (block) {
10686         assert(PL_parser);
10687         if (CvIsMETHOD(PL_compcv))
10688             block = class_wrap_method_body(block);
10689         /* This makes sub {}; work as expected.  */
10690         if (block->op_type == OP_STUB) {
10691             const line_t l = PL_parser->copline;
10692             op_free(block);
10693             block = newSTATEOP(0, NULL, 0);
10694             PL_parser->copline = l;
10695         }
10696         block = CvLVALUE(PL_compcv)
10697              || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
10698                     && (!isGV(gv) || !GvASSUMECV(gv)))
10699                    ? newUNOP(OP_LEAVESUBLV, 0,
10700                              op_lvalue(voidnonfinal(block), OP_LEAVESUBLV))
10701                    : newUNOP(OP_LEAVESUB, 0, voidnonfinal(block));
10702         start = LINKLIST(block);
10703         block->op_next = 0;
10704         if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv))
10705             const_sv =
10706                 S_op_const_sv(aTHX_ start, PL_compcv,
10707                                         cBOOL(CvCLONE(PL_compcv)));
10708         else
10709             const_sv = NULL;
10710     }
10711     else
10712         const_sv = NULL;
10713 
10714     if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
10715         cv_ckproto_len_flags((const CV *)gv,
10716                              o ? (const GV *)cSVOPo->op_sv : NULL, ps,
10717                              ps_len, ps_utf8|CV_CKPROTO_CURSTASH);
10718         if (SvROK(gv)) {
10719             /* All the other code for sub redefinition warnings expects the
10720                clobbered sub to be a CV.  Instead of making all those code
10721                paths more complex, just inline the RV version here.  */
10722             const line_t oldline = CopLINE(PL_curcop);
10723             assert(IN_PERL_COMPILETIME);
10724             if (PL_parser && PL_parser->copline != NOLINE)
10725                 /* This ensures that warnings are reported at the first
10726                    line of a redefinition, not the last.  */
10727                 CopLINE_set(PL_curcop, PL_parser->copline);
10728             /* protect against fatal warnings leaking compcv */
10729             SAVEFREESV(PL_compcv);
10730 
10731             if (ckWARN(WARN_REDEFINE)
10732              || (  ckWARN_d(WARN_REDEFINE)
10733                 && (  !const_sv || SvRV(gv) == const_sv
10734                       || SvTYPE(const_sv) == SVt_PVAV
10735                       || SvTYPE(SvRV(gv)) == SVt_PVAV
10736                       || sv_cmp(SvRV(gv), const_sv)  ))) {
10737                 assert(cSVOPo);
10738                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10739                           "Constant subroutine %" SVf " redefined",
10740                           SVfARG(cSVOPo->op_sv));
10741             }
10742 
10743             SvREFCNT_inc_simple_void_NN(PL_compcv);
10744             CopLINE_set(PL_curcop, oldline);
10745             SvREFCNT_dec(SvRV(gv));
10746         }
10747     }
10748 
10749     if (cv) {
10750         const bool exists = CvROOT(cv) || CvXSUB(cv);
10751 
10752         /* if the subroutine doesn't exist and wasn't pre-declared
10753          * with a prototype, assume it will be AUTOLOADed,
10754          * skipping the prototype check
10755          */
10756         if (exists || SvPOK(cv))
10757             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
10758         /* already defined (or promised)? */
10759         if (exists || (isGV(gv) && GvASSUMECV(gv))) {
10760             S_already_defined(aTHX_ cv, block, o, NULL, &const_sv);
10761             if (block)
10762                 cv = NULL;
10763             else {
10764                 if (attrs)
10765                     goto attrs;
10766                 /* just a "sub foo;" when &foo is already defined */
10767                 SAVEFREESV(PL_compcv);
10768                 goto done;
10769             }
10770         }
10771     }
10772 
10773     if (const_sv) {
10774         SvREFCNT_inc_simple_void_NN(const_sv);
10775         SvFLAGS(const_sv) |= SVs_PADTMP;
10776         if (cv) {
10777             assert(!CvROOT(cv) && !CvCONST(cv));
10778             cv_forget_slab(cv);
10779             SvPVCLEAR(MUTABLE_SV(cv));  /* prototype is "" */
10780             CvXSUBANY(cv).any_ptr = const_sv;
10781             CvXSUB(cv) = const_sv_xsub;
10782             CvCONST_on(cv);
10783             CvISXSUB_on(cv);
10784             PoisonPADLIST(cv);
10785             CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10786         }
10787         else {
10788             if (isGV(gv) || CvNOWARN_AMBIGUOUS(PL_compcv)) {
10789                 if (name && isGV(gv))
10790                     GvCV_set(gv, NULL);
10791                 cv = newCONSTSUB_flags(
10792                     NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
10793                     const_sv
10794                 );
10795                 assert(cv);
10796                 assert(SvREFCNT((SV*)cv) != 0);
10797                 CvFLAGS(cv) |= CvNOWARN_AMBIGUOUS(PL_compcv);
10798             }
10799             else {
10800                 if (!SvROK(gv)) {
10801                     SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10802                     prepare_SV_for_RV((SV *)gv);
10803                     SvOK_off((SV *)gv);
10804                     SvROK_on(gv);
10805                 }
10806                 SvRV_set(gv, const_sv);
10807             }
10808         }
10809         op_free(block);
10810         SvREFCNT_dec(PL_compcv);
10811         PL_compcv = NULL;
10812         goto done;
10813     }
10814 
10815     /* don't copy new BEGIN CV to old BEGIN CV - RT #129099 */
10816     if (name && cv && *name == 'B' && strEQ(name, "BEGIN"))
10817         cv = NULL;
10818 
10819     if (cv) {				/* must reuse cv if autoloaded */
10820         /* transfer PL_compcv to cv */
10821         if (block) {
10822             bool free_file = CvFILE(cv) && CvDYNFILE(cv);
10823             cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
10824             PADLIST *const temp_av = CvPADLIST(cv);
10825             CV *const temp_cv = CvOUTSIDE(cv);
10826             const cv_flags_t other_flags =
10827                 CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
10828             OP * const cvstart = CvSTART(cv);
10829 
10830             if (isGV(gv)) {
10831                 CvGV_set(cv,gv);
10832                 assert(!CvCVGV_RC(cv));
10833                 assert(CvGV(cv) == gv);
10834             }
10835             else {
10836                 U32 hash;
10837                 PERL_HASH(hash, name, namlen);
10838                 CvNAME_HEK_set(cv,
10839                                share_hek(name,
10840                                          name_is_utf8
10841                                             ? -(SSize_t)namlen
10842                                             :  (SSize_t)namlen,
10843                                          hash));
10844             }
10845 
10846             SvPOK_off(cv);
10847             CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs
10848                                              | CvNAMED(cv);
10849             CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
10850             CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
10851             CvPADLIST_set(cv,CvPADLIST(PL_compcv));
10852             CvOUTSIDE(PL_compcv) = temp_cv;
10853             CvPADLIST_set(PL_compcv, temp_av);
10854             CvSTART(cv) = CvSTART(PL_compcv);
10855             CvSTART(PL_compcv) = cvstart;
10856             CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
10857             CvFLAGS(PL_compcv) |= other_flags;
10858 
10859             if (free_file) {
10860                 Safefree(CvFILE(cv));
10861             }
10862             CvFILE_set_from_cop(cv, PL_curcop);
10863             CvSTASH_set(cv, PL_curstash);
10864 
10865             /* inner references to PL_compcv must be fixed up ... */
10866             pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
10867             if (PERLDB_INTER)/* Advice debugger on the new sub. */
10868                 ++PL_sub_generation;
10869         }
10870         else {
10871             /* Might have had built-in attributes applied -- propagate them. */
10872             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
10873         }
10874         /* ... before we throw it away */
10875         SvREFCNT_dec(PL_compcv);
10876         PL_compcv = cv;
10877     }
10878     else {
10879         cv = PL_compcv;
10880         if (name && isGV(gv)) {
10881             GvCV_set(gv, cv);
10882             GvCVGEN(gv) = 0;
10883             if (HvENAME_HEK(GvSTASH(gv)))
10884                 /* sub Foo::bar { (shift)+1 } */
10885                 gv_method_changed(gv);
10886         }
10887         else if (name) {
10888             if (!SvROK(gv)) {
10889                 SV_CHECK_THINKFIRST_COW_DROP((SV *)gv);
10890                 prepare_SV_for_RV((SV *)gv);
10891                 SvOK_off((SV *)gv);
10892                 SvROK_on(gv);
10893             }
10894             SvRV_set(gv, (SV *)cv);
10895             if (HvENAME_HEK(PL_curstash))
10896                 mro_method_changed_in(PL_curstash);
10897         }
10898     }
10899     assert(cv);
10900     assert(SvREFCNT((SV*)cv) != 0);
10901 
10902     if (!CvHASGV(cv)) {
10903         if (isGV(gv))
10904             CvGV_set(cv, gv);
10905         else {
10906             U32 hash;
10907             PERL_HASH(hash, name, namlen);
10908             CvNAME_HEK_set(cv, share_hek(name,
10909                                          name_is_utf8
10910                                             ? -(SSize_t)namlen
10911                                             :  (SSize_t)namlen,
10912                                          hash));
10913         }
10914         CvFILE_set_from_cop(cv, PL_curcop);
10915         CvSTASH_set(cv, PL_curstash);
10916     }
10917 
10918     if (ps) {
10919         sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
10920         if ( ps_utf8 )
10921             SvUTF8_on(MUTABLE_SV(cv));
10922     }
10923 
10924     if (block) {
10925         /* If we assign an optree to a PVCV, then we've defined a
10926          * subroutine that the debugger could be able to set a breakpoint
10927          * in, so signal to pp_entereval that it should not throw away any
10928          * saved lines at scope exit.  */
10929 
10930         PL_breakable_sub_gen++;
10931         CvROOT(cv) = block;
10932         /* The cv no longer needs to hold a refcount on the slab, as CvROOT
10933            itself has a refcount. */
10934         CvSLABBED_off(cv);
10935         OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
10936 #ifdef PERL_DEBUG_READONLY_OPS
10937         slab = (OPSLAB *)CvSTART(cv);
10938 #endif
10939         S_process_optree(aTHX_ cv, block, start);
10940     }
10941 
10942   attrs:
10943     if (attrs) {
10944         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
10945         HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv))
10946                         ? GvSTASH(CvGV(cv))
10947                         : PL_curstash;
10948         if (!name)
10949             SAVEFREESV(cv);
10950         apply_attrs(stash, MUTABLE_SV(cv), attrs);
10951         if (!name)
10952             SvREFCNT_inc_simple_void_NN(cv);
10953     }
10954 
10955     if (block && has_name) {
10956         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
10957             SV * const tmpstr = cv_name(cv,NULL,0);
10958             GV * const db_postponed = gv_fetchpvs("DB::postponed",
10959                                                   GV_ADDMULTI, SVt_PVHV);
10960             HV *hv;
10961             SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" LINE_Tf "-%" LINE_Tf,
10962                                           CopFILE(PL_curcop),
10963                                           (line_t)PL_subline,
10964                                           CopLINE(PL_curcop));
10965             (void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
10966             hv = GvHVn(db_postponed);
10967             if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
10968                 CV * const pcv = GvCV(db_postponed);
10969                 if (pcv) {
10970                     dSP;
10971                     PUSHMARK(SP);
10972                     XPUSHs(tmpstr);
10973                     PUTBACK;
10974                     call_sv(MUTABLE_SV(pcv), G_DISCARD);
10975                 }
10976             }
10977         }
10978 
10979         if (name) {
10980             if (PL_parser && PL_parser->error_count)
10981                 clear_special_blocks(name, gv, cv);
10982             else
10983                 evanescent =
10984                     process_special_blocks(floor, name, gv, cv);
10985         }
10986     }
10987     assert(cv);
10988 
10989   done:
10990     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10991     if (PL_parser)
10992         PL_parser->copline = NOLINE;
10993     LEAVE_SCOPE(floor);
10994 
10995     assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
10996     if (!evanescent) {
10997 #ifdef PERL_DEBUG_READONLY_OPS
10998     if (slab)
10999         Slab_to_ro(slab);
11000 #endif
11001     if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
11002         pad_add_weakref(cv);
11003     }
11004     return cv;
11005 }
11006 
11007 STATIC void
S_clear_special_blocks(pTHX_ const char * const fullname,GV * const gv,CV * const cv)11008 S_clear_special_blocks(pTHX_ const char *const fullname,
11009                        GV *const gv, CV *const cv) {
11010     const char *colon;
11011     const char *name;
11012 
11013     PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
11014 
11015     colon = strrchr(fullname,':');
11016     name = colon ? colon + 1 : fullname;
11017 
11018     if ((*name == 'B' && strEQ(name, "BEGIN"))
11019         || (*name == 'E' && strEQ(name, "END"))
11020         || (*name == 'U' && strEQ(name, "UNITCHECK"))
11021         || (*name == 'C' && strEQ(name, "CHECK"))
11022         || (*name == 'I' && strEQ(name, "INIT"))) {
11023         if (!isGV(gv)) {
11024             (void)CvGV(cv);
11025             assert(isGV(gv));
11026         }
11027         GvCV_set(gv, NULL);
11028         SvREFCNT_dec_NN(MUTABLE_SV(cv));
11029     }
11030 }
11031 
11032 /* Returns true if the sub has been freed.  */
11033 STATIC bool
S_process_special_blocks(pTHX_ I32 floor,const char * const fullname,GV * const gv,CV * const cv)11034 S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
11035                          GV *const gv,
11036                          CV *const cv)
11037 {
11038     const char *const colon = strrchr(fullname,':');
11039     const char *const name = colon ? colon + 1 : fullname;
11040 
11041     PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
11042 
11043     if (*name == 'B') {
11044         if (strEQ(name, "BEGIN")) {
11045             /* can't goto a declaration, but a null statement is fine */
11046             module_install_hack: ;
11047             const I32 oldscope = PL_scopestack_ix;
11048             SV *max_nest_sv = NULL;
11049             IV max_nest_iv;
11050             dSP;
11051             (void)CvGV(cv);
11052             if (floor) LEAVE_SCOPE(floor);
11053             ENTER;
11054 
11055             /* Make sure we don't recurse too deeply into BEGIN blocks,
11056              * but let the user control it via the new control variable
11057              *
11058              *   ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}
11059              *
11060              * Note that this code (when max_nest_iv is 1) *looks* like
11061              * it would block the following code:
11062              *
11063              * BEGIN { $n |= 1; BEGIN { $n |= 2; BEGIN { $n |= 4 } } }
11064              *
11065              * but it does *not*; this code will happily execute when
11066              * the nest limit is 1. The reason is revealed in the
11067              * execution order. If we could watch $n in this code, we
11068              * would see the following order of modifications:
11069              *
11070              * $n |= 4;
11071              * $n |= 2;
11072              * $n |= 1;
11073              *
11074              * This is because nested BEGIN blocks execute in FILO
11075              * order; this is because BEGIN blocks are defined to
11076              * execute immediately once they are closed. So the
11077              * innermost block is closed first, and it executes, which
11078              * increments the eval_begin_nest_depth by 1, and then it
11079              * finishes, which drops eval_begin_nest_depth back to its
11080              * previous value. This happens in turn as each BEGIN is
11081              * completed.
11082              *
11083              * The *only* place these counts matter is when BEGIN is
11084              * inside of some kind of string eval, either a require or a
11085              * true eval. Only in that case would there be any nesting
11086              * and would perl try to execute a BEGIN before another had
11087              * completed.
11088              *
11089              * Thus this logic puts an upper limit on module nesting.
11090              * Hence the reason we let the user control it, although it
11091              * is hard to imagine a 1000-level-deep module use
11092              * dependency even in a very large codebase. The real
11093              * objective is to prevent code like this:
11094              *
11095              * perl -e'sub f { eval "BEGIN { f() }" } f()'
11096              *
11097              * from segfaulting due to stack exhaustion.
11098              *
11099              */
11100             max_nest_sv = get_sv(PERL_VAR_MAX_NESTED_EVAL_BEGIN_BLOCKS, GV_ADD);
11101             if (!SvOK(max_nest_sv))
11102                 sv_setiv(max_nest_sv, PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT);
11103             max_nest_iv = SvIV(max_nest_sv);
11104             if (max_nest_iv < 0) {
11105                 max_nest_iv = PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT;
11106                 sv_setiv(max_nest_sv, max_nest_iv);
11107             }
11108 
11109             /* (UV) below is just to silence a compiler warning, and should be
11110              * effectively a no-op, as max_nest_iv will never be negative here.
11111              */
11112             if (PL_eval_begin_nest_depth >= (UV)max_nest_iv) {
11113                 Perl_croak(aTHX_ "Too many nested BEGIN blocks, maximum of %" IVdf " allowed",
11114                              max_nest_iv);
11115             }
11116             SAVEINT(PL_eval_begin_nest_depth);
11117             PL_eval_begin_nest_depth++;
11118 
11119             SAVEVPTR(PL_curcop);
11120             if (PL_curcop == &PL_compiling) {
11121                 /* Avoid pushing the "global" &PL_compiling onto the
11122                  * context stack. For example, a stack trace inside
11123                  * nested use's would show all calls coming from whoever
11124                  * most recently updated PL_compiling.cop_file and
11125                  * cop_line.  So instead, temporarily set PL_curcop to a
11126                  * private copy of &PL_compiling. PL_curcop will soon be
11127                  * set to point back to &PL_compiling anyway but only
11128                  * after the temp value has been pushed onto the context
11129                  * stack as blk_oldcop.
11130                  * This is slightly hacky, but necessary. Note also
11131                  * that in the brief window before PL_curcop is set back
11132                  * to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
11133                  * will give the wrong answer.
11134                  */
11135                 PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
11136                 CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
11137                 SAVEFREEOP(PL_curcop);
11138             }
11139 
11140             PUSHSTACKi(PERLSI_REQUIRE);
11141             SAVECOPFILE(&PL_compiling);
11142             SAVECOPLINE(&PL_compiling);
11143 
11144             DEBUG_x( dump_sub(gv) );
11145             Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
11146             GvCV_set(gv,0);		/* cv has been hijacked */
11147             call_list(oldscope, PL_beginav);
11148 
11149             POPSTACK;
11150             LEAVE;
11151             return !PL_savebegin;
11152         }
11153         else
11154             return FALSE;
11155     } else {
11156         if (*name == 'E') {
11157             if (strEQ(name, "END")) {
11158                 DEBUG_x( dump_sub(gv) );
11159                 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
11160             } else
11161                 return FALSE;
11162         } else if (*name == 'U') {
11163             if (strEQ(name, "UNITCHECK")) {
11164                 /* It's never too late to run a unitcheck block */
11165                 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
11166             }
11167             else
11168                 return FALSE;
11169         } else if (*name == 'C') {
11170             if (strEQ(name, "CHECK")) {
11171                 if (PL_main_start)
11172                     /* diag_listed_as: Too late to run %s block */
11173                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11174                                    "Too late to run CHECK block");
11175                 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
11176             }
11177             else
11178                 return FALSE;
11179         } else if (*name == 'I') {
11180             if (strEQ(name, "INIT")) {
11181 #ifdef MI_INIT_WORKAROUND_PACK
11182                 {
11183                     HV *hv = CvSTASH(cv);
11184                     STRLEN len = hv ? HvNAMELEN(hv) : 0;
11185                     char *pv = (len == sizeof(MI_INIT_WORKAROUND_PACK)-1)
11186                             ? HvNAME_get(hv) : NULL;
11187                     if ( pv && strEQ(pv, MI_INIT_WORKAROUND_PACK) ) {
11188                         /* old versions of Module::Install::DSL contain code
11189                          * that creates an INIT in eval, which expects to run
11190                          * after an exit(0) in BEGIN. This unfortunately
11191                          * breaks a lot of code in the CPAN river. So we magically
11192                          * convert INIT blocks from Module::Install::DSL to
11193                          * be BEGIN blocks. Which works out, since the INIT
11194                          * blocks it creates are eval'ed and so are late.
11195                          */
11196                         Perl_warn(aTHX_ "Treating %s::INIT block as BEGIN block as workaround",
11197                                 MI_INIT_WORKAROUND_PACK);
11198                         goto module_install_hack;
11199                     }
11200 
11201                 }
11202 #endif
11203                 if (PL_main_start)
11204                     /* diag_listed_as: Too late to run %s block */
11205                     Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
11206                                    "Too late to run INIT block");
11207                 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
11208             }
11209             else
11210                 return FALSE;
11211         } else
11212             return FALSE;
11213         DEBUG_x( dump_sub(gv) );
11214         (void)CvGV(cv);
11215         GvCV_set(gv,0);		/* cv has been hijacked */
11216         return FALSE;
11217     }
11218 }
11219 
11220 /*
11221 =for apidoc newCONSTSUB
11222 
11223 Behaves like L</newCONSTSUB_flags>, except that C<name> is nul-terminated
11224 rather than of counted length, and no flags are set.  (This means that
11225 C<name> is always interpreted as Latin-1.)
11226 
11227 =cut
11228 */
11229 
11230 CV *
Perl_newCONSTSUB(pTHX_ HV * stash,const char * name,SV * sv)11231 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
11232 {
11233     return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
11234 }
11235 
11236 /*
11237 =for apidoc newCONSTSUB_flags
11238 
11239 Construct a constant subroutine, also performing some surrounding
11240 jobs.  A scalar constant-valued subroutine is eligible for inlining
11241 at compile-time, and in Perl code can be created by S<C<sub FOO () {
11242 123 }>>.  Other kinds of constant subroutine have other treatment.
11243 
11244 The subroutine will have an empty prototype and will ignore any arguments
11245 when called.  Its constant behaviour is determined by C<sv>.  If C<sv>
11246 is null, the subroutine will yield an empty list.  If C<sv> points to a
11247 scalar, the subroutine will always yield that scalar.  If C<sv> points
11248 to an array, the subroutine will always yield a list of the elements of
11249 that array in list context, or the number of elements in the array in
11250 scalar context.  This function takes ownership of one counted reference
11251 to the scalar or array, and will arrange for the object to live as long
11252 as the subroutine does.  If C<sv> points to a scalar then the inlining
11253 assumes that the value of the scalar will never change, so the caller
11254 must ensure that the scalar is not subsequently written to.  If C<sv>
11255 points to an array then no such assumption is made, so it is ostensibly
11256 safe to mutate the array or its elements, but whether this is really
11257 supported has not been determined.
11258 
11259 The subroutine will have C<CvFILE> set according to C<PL_curcop>.
11260 Other aspects of the subroutine will be left in their default state.
11261 The caller is free to mutate the subroutine beyond its initial state
11262 after this function has returned.
11263 
11264 If C<name> is null then the subroutine will be anonymous, with its
11265 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
11266 subroutine will be named accordingly, referenced by the appropriate glob.
11267 C<name> is a string of length C<len> bytes giving a sigilless symbol
11268 name, in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1
11269 otherwise.  The name may be either qualified or unqualified.  If the
11270 name is unqualified then it defaults to being in the stash specified by
11271 C<stash> if that is non-null, or to C<PL_curstash> if C<stash> is null.
11272 The symbol is always added to the stash if necessary, with C<GV_ADDMULTI>
11273 semantics.
11274 
11275 C<flags> should not have bits set other than C<SVf_UTF8>.
11276 
11277 If there is already a subroutine of the specified name, then the new sub
11278 will replace the existing one in the glob.  A warning may be generated
11279 about the redefinition.
11280 
11281 If the subroutine has one of a few special names, such as C<BEGIN> or
11282 C<END>, then it will be claimed by the appropriate queue for automatic
11283 running of phase-related subroutines.  In this case the relevant glob will
11284 be left not containing any subroutine, even if it did contain one before.
11285 Execution of the subroutine will likely be a no-op, unless C<sv> was
11286 a tied array or the caller modified the subroutine in some interesting
11287 way before it was executed.  In the case of C<BEGIN>, the treatment is
11288 buggy: the sub will be executed when only half built, and may be deleted
11289 prematurely, possibly causing a crash.
11290 
11291 The function returns a pointer to the constructed subroutine.  If the sub
11292 is anonymous then ownership of one counted reference to the subroutine
11293 is transferred to the caller.  If the sub is named then the caller does
11294 not get ownership of a reference.  In most such cases, where the sub
11295 has a non-phase name, the sub will be alive at the point it is returned
11296 by virtue of being contained in the glob that names it.  A phase-named
11297 subroutine will usually be alive by virtue of the reference owned by
11298 the phase's automatic run queue.  A C<BEGIN> subroutine may have been
11299 destroyed already by the time this function returns, but currently bugs
11300 occur in that case before the caller gets control.  It is the caller's
11301 responsibility to ensure that it knows which of these situations applies.
11302 
11303 =cut
11304 */
11305 
11306 CV *
Perl_newCONSTSUB_flags(pTHX_ HV * stash,const char * name,STRLEN len,U32 flags,SV * sv)11307 Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, STRLEN len,
11308                              U32 flags, SV *sv)
11309 {
11310     CV* cv;
11311     const char *const file = CopFILE(PL_curcop);
11312 
11313     ENTER;
11314 
11315     if (IN_PERL_RUNTIME) {
11316         /* at runtime, it's not safe to manipulate PL_curcop: it may be
11317          * an op shared between threads. Use a non-shared COP for our
11318          * dirty work */
11319          SAVEVPTR(PL_curcop);
11320          SAVECOMPILEWARNINGS();
11321          PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
11322          PL_curcop = &PL_compiling;
11323     }
11324     SAVECOPLINE(PL_curcop);
11325     CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
11326 
11327     SAVEHINTS();
11328     PL_hints &= ~HINT_BLOCK_SCOPE;
11329 
11330     if (stash) {
11331         SAVEGENERICSV(PL_curstash);
11332         PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
11333     }
11334 
11335     /* Protect sv against leakage caused by fatal warnings. */
11336     if (sv) SAVEFREESV(sv);
11337 
11338     /* file becomes the CvFILE. For an XS, it's usually static storage,
11339        and so doesn't get free()d.  (It's expected to be from the C pre-
11340        processor __FILE__ directive). But we need a dynamically allocated one,
11341        and we need it to get freed.  */
11342     cv = newXS_len_flags(name, len,
11343                          sv && SvTYPE(sv) == SVt_PVAV
11344                              ? const_av_xsub
11345                              : const_sv_xsub,
11346                          file ? file : "", "",
11347                          &sv, XS_DYNAMIC_FILENAME | flags);
11348     assert(cv);
11349     assert(SvREFCNT((SV*)cv) != 0);
11350     CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
11351     CvCONST_on(cv);
11352 
11353     LEAVE;
11354 
11355     return cv;
11356 }
11357 
11358 /*
11359 =for apidoc newXS
11360 
11361 Used by C<xsubpp> to hook up XSUBs as Perl subs.  C<filename> needs to be
11362 static storage, as it is used directly as CvFILE(), without a copy being made.
11363 
11364 =cut
11365 */
11366 
11367 CV *
Perl_newXS(pTHX_ const char * name,XSUBADDR_t subaddr,const char * filename)11368 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
11369 {
11370     PERL_ARGS_ASSERT_NEWXS;
11371     return newXS_len_flags(
11372         name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
11373     );
11374 }
11375 
11376 CV *
Perl_newXS_flags(pTHX_ const char * name,XSUBADDR_t subaddr,const char * const filename,const char * const proto,U32 flags)11377 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
11378                  const char *const filename, const char *const proto,
11379                  U32 flags)
11380 {
11381     PERL_ARGS_ASSERT_NEWXS_FLAGS;
11382     return newXS_len_flags(
11383        name, name ? strlen(name) : 0, subaddr, filename, proto, NULL, flags
11384     );
11385 }
11386 
11387 CV *
Perl_newXS_deffile(pTHX_ const char * name,XSUBADDR_t subaddr)11388 Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
11389 {
11390     PERL_ARGS_ASSERT_NEWXS_DEFFILE;
11391     return newXS_len_flags(
11392         name, strlen(name), subaddr, NULL, NULL, NULL, 0
11393     );
11394 }
11395 
11396 /*
11397 =for apidoc newXS_len_flags
11398 
11399 Construct an XS subroutine, also performing some surrounding jobs.
11400 
11401 The subroutine will have the entry point C<subaddr>.  It will have
11402 the prototype specified by the nul-terminated string C<proto>, or
11403 no prototype if C<proto> is null.  The prototype string is copied;
11404 the caller can mutate the supplied string afterwards.  If C<filename>
11405 is non-null, it must be a nul-terminated filename, and the subroutine
11406 will have its C<CvFILE> set accordingly.  By default C<CvFILE> is set to
11407 point directly to the supplied string, which must be static.  If C<flags>
11408 has the C<XS_DYNAMIC_FILENAME> bit set, then a copy of the string will
11409 be taken instead.
11410 
11411 Other aspects of the subroutine will be left in their default state.
11412 If anything else needs to be done to the subroutine for it to function
11413 correctly, it is the caller's responsibility to do that after this
11414 function has constructed it.  However, beware of the subroutine
11415 potentially being destroyed before this function returns, as described
11416 below.
11417 
11418 If C<name> is null then the subroutine will be anonymous, with its
11419 C<CvGV> referring to an C<__ANON__> glob.  If C<name> is non-null then the
11420 subroutine will be named accordingly, referenced by the appropriate glob.
11421 C<name> is a string of length C<len> bytes giving a sigilless symbol name,
11422 in UTF-8 if C<flags> has the C<SVf_UTF8> bit set and in Latin-1 otherwise.
11423 The name may be either qualified or unqualified, with the stash defaulting
11424 in the same manner as for C<gv_fetchpvn_flags>.  C<flags> may contain
11425 flag bits understood by C<gv_fetchpvn_flags> with the same meaning as
11426 they have there, such as C<GV_ADDWARN>.  The symbol is always added to
11427 the stash if necessary, with C<GV_ADDMULTI> semantics.
11428 
11429 If there is already a subroutine of the specified name, then the new sub
11430 will replace the existing one in the glob.  A warning may be generated
11431 about the redefinition.  If the old subroutine was C<CvCONST> then the
11432 decision about whether to warn is influenced by an expectation about
11433 whether the new subroutine will become a constant of similar value.
11434 That expectation is determined by C<const_svp>.  (Note that the call to
11435 this function doesn't make the new subroutine C<CvCONST> in any case;
11436 that is left to the caller.)  If C<const_svp> is null then it indicates
11437 that the new subroutine will not become a constant.  If C<const_svp>
11438 is non-null then it indicates that the new subroutine will become a
11439 constant, and it points to an C<SV*> that provides the constant value
11440 that the subroutine will have.
11441 
11442 If the subroutine has one of a few special names, such as C<BEGIN> or
11443 C<END>, then it will be claimed by the appropriate queue for automatic
11444 running of phase-related subroutines.  In this case the relevant glob will
11445 be left not containing any subroutine, even if it did contain one before.
11446 In the case of C<BEGIN>, the subroutine will be executed and the reference
11447 to it disposed of before this function returns, and also before its
11448 prototype is set.  If a C<BEGIN> subroutine would not be sufficiently
11449 constructed by this function to be ready for execution then the caller
11450 must prevent this happening by giving the subroutine a different name.
11451 
11452 The function returns a pointer to the constructed subroutine.  If the sub
11453 is anonymous then ownership of one counted reference to the subroutine
11454 is transferred to the caller.  If the sub is named then the caller does
11455 not get ownership of a reference.  In most such cases, where the sub
11456 has a non-phase name, the sub will be alive at the point it is returned
11457 by virtue of being contained in the glob that names it.  A phase-named
11458 subroutine will usually be alive by virtue of the reference owned by the
11459 phase's automatic run queue.  But a C<BEGIN> subroutine, having already
11460 been executed, will quite likely have been destroyed already by the
11461 time this function returns, making it erroneous for the caller to make
11462 any use of the returned pointer.  It is the caller's responsibility to
11463 ensure that it knows which of these situations applies.
11464 
11465 =cut
11466 */
11467 
11468 CV *
Perl_newXS_len_flags(pTHX_ const char * name,STRLEN len,XSUBADDR_t subaddr,const char * const filename,const char * const proto,SV ** const_svp,U32 flags)11469 Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
11470                            XSUBADDR_t subaddr, const char *const filename,
11471                            const char *const proto, SV **const_svp,
11472                            U32 flags)
11473 {
11474     CV *cv;
11475     bool interleave = FALSE;
11476     bool evanescent = FALSE;
11477 
11478     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
11479 
11480     {
11481         GV * const gv = gv_fetchpvn(
11482                             name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
11483                             name ? len : PL_curstash ? sizeof("__ANON__") - 1:
11484                                 sizeof("__ANON__::__ANON__") - 1,
11485                             GV_ADDMULTI | flags, SVt_PVCV);
11486 
11487         if ((cv = (name ? GvCV(gv) : NULL))) {
11488             if (GvCVGEN(gv)) {
11489                 /* just a cached method */
11490                 SvREFCNT_dec(cv);
11491                 cv = NULL;
11492             }
11493             else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
11494                 /* already defined (or promised) */
11495                 /* Redundant check that allows us to avoid creating an SV
11496                    most of the time: */
11497                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
11498                     report_redefined_cv(newSVpvn_flags(
11499                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
11500                                         ),
11501                                         cv, const_svp);
11502                 }
11503                 interleave = TRUE;
11504                 ENTER;
11505                 SAVEFREESV(cv);
11506                 cv = NULL;
11507             }
11508         }
11509 
11510         if (cv)				/* must reuse cv if autoloaded */
11511             cv_undef(cv);
11512         else {
11513             cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11514             if (name) {
11515                 GvCV_set(gv,cv);
11516                 GvCVGEN(gv) = 0;
11517                 if (HvENAME_HEK(GvSTASH(gv)))
11518                     gv_method_changed(gv); /* newXS */
11519             }
11520         }
11521         assert(cv);
11522         assert(SvREFCNT((SV*)cv) != 0);
11523 
11524         CvGV_set(cv, gv);
11525         if(filename) {
11526             /* XSUBs can't be perl lang/perl5db.pl debugged
11527             if (PERLDB_LINE_OR_SAVESRC)
11528                 (void)gv_fetchfile(filename); */
11529             assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
11530             if (flags & XS_DYNAMIC_FILENAME) {
11531                 CvDYNFILE_on(cv);
11532                 CvFILE(cv) = savepv(filename);
11533             } else {
11534             /* NOTE: not copied, as it is expected to be an external constant string */
11535                 CvFILE(cv) = (char *)filename;
11536             }
11537         } else {
11538             assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
11539             CvFILE(cv) = (char*)PL_xsubfilename;
11540         }
11541         CvISXSUB_on(cv);
11542         CvXSUB(cv) = subaddr;
11543 #ifndef MULTIPLICITY
11544         CvHSCXT(cv) = &PL_stack_sp;
11545 #else
11546         PoisonPADLIST(cv);
11547 #endif
11548 
11549         if (name)
11550             evanescent = process_special_blocks(0, name, gv, cv);
11551         else
11552             CvANON_on(cv);
11553     } /* <- not a conditional branch */
11554 
11555     assert(cv);
11556     assert(evanescent || SvREFCNT((SV*)cv) != 0);
11557 
11558     if (!evanescent) sv_setpv(MUTABLE_SV(cv), proto);
11559     if (interleave) LEAVE;
11560     assert(evanescent || SvREFCNT((SV*)cv) != 0);
11561     return cv;
11562 }
11563 
11564 /* Add a stub CV to a typeglob.
11565  * This is the implementation of a forward declaration, 'sub foo';'
11566  */
11567 
11568 CV *
Perl_newSTUB(pTHX_ GV * gv,bool fake)11569 Perl_newSTUB(pTHX_ GV *gv, bool fake)
11570 {
11571     CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
11572     GV *cvgv;
11573     PERL_ARGS_ASSERT_NEWSTUB;
11574     assert(!GvCVu(gv));
11575     GvCV_set(gv, cv);
11576     GvCVGEN(gv) = 0;
11577     if (!fake && GvSTASH(gv) && HvENAME_HEK(GvSTASH(gv)))
11578         gv_method_changed(gv);
11579     if (SvFAKE(gv)) {
11580         cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
11581         SvFAKE_off(cvgv);
11582     }
11583     else cvgv = gv;
11584     CvGV_set(cv, cvgv);
11585     CvFILE_set_from_cop(cv, PL_curcop);
11586     CvSTASH_set(cv, PL_curstash);
11587     GvMULTI_on(gv);
11588     return cv;
11589 }
11590 
11591 void
Perl_newFORM(pTHX_ I32 floor,OP * o,OP * block)11592 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
11593 {
11594     CV *cv;
11595     GV *gv;
11596     OP *root;
11597     OP *start;
11598 
11599     if (PL_parser && PL_parser->error_count) {
11600         op_free(block);
11601         goto finish;
11602     }
11603 
11604     gv = o
11605         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
11606         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
11607 
11608     GvMULTI_on(gv);
11609     if ((cv = GvFORM(gv))) {
11610         if (ckWARN(WARN_REDEFINE)) {
11611             const line_t oldline = CopLINE(PL_curcop);
11612             if (PL_parser && PL_parser->copline != NOLINE)
11613                 CopLINE_set(PL_curcop, PL_parser->copline);
11614             if (o) {
11615                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11616                             "Format %" SVf " redefined", SVfARG(cSVOPo->op_sv));
11617             } else {
11618                 /* diag_listed_as: Format %s redefined */
11619                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
11620                             "Format STDOUT redefined");
11621             }
11622             CopLINE_set(PL_curcop, oldline);
11623         }
11624         SvREFCNT_dec(cv);
11625     }
11626     cv = PL_compcv;
11627     GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
11628     CvGV_set(cv, gv);
11629     CvFILE_set_from_cop(cv, PL_curcop);
11630 
11631 
11632     root = newUNOP(OP_LEAVEWRITE, 0, voidnonfinal(block));
11633     CvROOT(cv) = root;
11634     start = LINKLIST(root);
11635     root->op_next = 0;
11636     S_process_optree(aTHX_ cv, root, start);
11637     cv_forget_slab(cv);
11638 
11639   finish:
11640     op_free(o);
11641     if (PL_parser)
11642         PL_parser->copline = NOLINE;
11643     LEAVE_SCOPE(floor);
11644     PL_compiling.cop_seq = 0;
11645 }
11646 
11647 OP *
Perl_newANONLIST(pTHX_ OP * o)11648 Perl_newANONLIST(pTHX_ OP *o)
11649 {
11650     return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
11651 }
11652 
11653 OP *
Perl_newANONHASH(pTHX_ OP * o)11654 Perl_newANONHASH(pTHX_ OP *o)
11655 {
11656     return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
11657 }
11658 
11659 OP *
Perl_newANONSUB(pTHX_ I32 floor,OP * proto,OP * block)11660 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
11661 {
11662     return newANONATTRSUB(floor, proto, NULL, block);
11663 }
11664 
11665 OP *
Perl_newANONATTRSUB(pTHX_ I32 floor,OP * proto,OP * attrs,OP * block)11666 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
11667 {
11668     SV * const cv = MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block));
11669 
11670     bool is_const = CvANONCONST(cv);
11671 
11672     OP * anoncode =
11673         newSVOP(OP_ANONCODE, is_const ? 0 : OPf_REF,
11674                 cv);
11675 
11676     if (is_const) {
11677         anoncode = newUNOP(OP_ANONCONST, OPf_REF,
11678                            op_convert_list(OP_ENTERSUB,
11679                                            OPf_STACKED|OPf_WANT_SCALAR,
11680                                            anoncode));
11681     }
11682 
11683     return anoncode;
11684 }
11685 
11686 OP *
Perl_oopsAV(pTHX_ OP * o)11687 Perl_oopsAV(pTHX_ OP *o)
11688 {
11689 
11690     PERL_ARGS_ASSERT_OOPSAV;
11691 
11692     switch (o->op_type) {
11693     case OP_PADSV:
11694     case OP_PADHV:
11695         OpTYPE_set(o, OP_PADAV);
11696         return ref(o, OP_RV2AV);
11697 
11698     case OP_RV2SV:
11699     case OP_RV2HV:
11700         OpTYPE_set(o, OP_RV2AV);
11701         ref(o, OP_RV2AV);
11702         break;
11703 
11704     default:
11705         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
11706         break;
11707     }
11708     return o;
11709 }
11710 
11711 OP *
Perl_oopsHV(pTHX_ OP * o)11712 Perl_oopsHV(pTHX_ OP *o)
11713 {
11714 
11715     PERL_ARGS_ASSERT_OOPSHV;
11716 
11717     switch (o->op_type) {
11718     case OP_PADSV:
11719     case OP_PADAV:
11720         OpTYPE_set(o, OP_PADHV);
11721         return ref(o, OP_RV2HV);
11722 
11723     case OP_RV2SV:
11724     case OP_RV2AV:
11725         OpTYPE_set(o, OP_RV2HV);
11726         /* rv2hv steals the bottom bit for its own uses */
11727         o->op_private &= ~OPpARG1_MASK;
11728         ref(o, OP_RV2HV);
11729         break;
11730 
11731     default:
11732         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
11733         break;
11734     }
11735     return o;
11736 }
11737 
11738 OP *
Perl_newAVREF(pTHX_ OP * o)11739 Perl_newAVREF(pTHX_ OP *o)
11740 {
11741 
11742     PERL_ARGS_ASSERT_NEWAVREF;
11743 
11744     if (o->op_type == OP_PADANY) {
11745         OpTYPE_set(o, OP_PADAV);
11746         return o;
11747     }
11748     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
11749         Perl_croak(aTHX_ "Can't use an array as a reference");
11750     }
11751     return newUNOP(OP_RV2AV, 0, scalar(o));
11752 }
11753 
11754 OP *
Perl_newGVREF(pTHX_ I32 type,OP * o)11755 Perl_newGVREF(pTHX_ I32 type, OP *o)
11756 {
11757     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
11758         return newUNOP(OP_NULL, 0, o);
11759 
11760     if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED &&
11761         ((PL_opargs[type] >> OASHIFT) & 7) == OA_FILEREF &&
11762         o->op_type == OP_CONST && (o->op_private & OPpCONST_BARE)) {
11763         no_bareword_filehandle(SvPVX(cSVOPo_sv));
11764     }
11765 
11766     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
11767 }
11768 
11769 OP *
Perl_newHVREF(pTHX_ OP * o)11770 Perl_newHVREF(pTHX_ OP *o)
11771 {
11772 
11773     PERL_ARGS_ASSERT_NEWHVREF;
11774 
11775     if (o->op_type == OP_PADANY) {
11776         OpTYPE_set(o, OP_PADHV);
11777         return o;
11778     }
11779     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
11780         Perl_croak(aTHX_ "Can't use a hash as a reference");
11781     }
11782     return newUNOP(OP_RV2HV, 0, scalar(o));
11783 }
11784 
11785 OP *
Perl_newCVREF(pTHX_ I32 flags,OP * o)11786 Perl_newCVREF(pTHX_ I32 flags, OP *o)
11787 {
11788     if (o->op_type == OP_PADANY) {
11789         OpTYPE_set(o, OP_PADCV);
11790     }
11791     return newUNOP(OP_RV2CV, flags, scalar(o));
11792 }
11793 
11794 OP *
Perl_newSVREF(pTHX_ OP * o)11795 Perl_newSVREF(pTHX_ OP *o)
11796 {
11797 
11798     PERL_ARGS_ASSERT_NEWSVREF;
11799 
11800     if (o->op_type == OP_PADANY) {
11801         OpTYPE_set(o, OP_PADSV);
11802         scalar(o);
11803         return o;
11804     }
11805     return newUNOP(OP_RV2SV, 0, scalar(o));
11806 }
11807 
11808 /* Check routines. See the comments at the top of this file for details
11809  * on when these are called */
11810 
11811 OP *
Perl_ck_anoncode(pTHX_ OP * o)11812 Perl_ck_anoncode(pTHX_ OP *o)
11813 {
11814     PERL_ARGS_ASSERT_CK_ANONCODE;
11815 
11816     cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type);
11817     cSVOPo->op_sv = NULL;
11818     return o;
11819 }
11820 
11821 static void
S_io_hints(pTHX_ OP * o)11822 S_io_hints(pTHX_ OP *o)
11823 {
11824 #if O_BINARY != 0 || O_TEXT != 0
11825     HV * const table =
11826         PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;;
11827     if (table) {
11828         SV **svp = hv_fetchs(table, "open_IN", FALSE);
11829         if (svp && *svp) {
11830             STRLEN len = 0;
11831             const char *d = SvPV_const(*svp, len);
11832             const I32 mode = mode_from_discipline(d, len);
11833             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11834 #  if O_BINARY != 0
11835             if (mode & O_BINARY)
11836                 o->op_private |= OPpOPEN_IN_RAW;
11837 #  endif
11838 #  if O_TEXT != 0
11839             if (mode & O_TEXT)
11840                 o->op_private |= OPpOPEN_IN_CRLF;
11841 #  endif
11842         }
11843 
11844         svp = hv_fetchs(table, "open_OUT", FALSE);
11845         if (svp && *svp) {
11846             STRLEN len = 0;
11847             const char *d = SvPV_const(*svp, len);
11848             const I32 mode = mode_from_discipline(d, len);
11849             /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */
11850 #  if O_BINARY != 0
11851             if (mode & O_BINARY)
11852                 o->op_private |= OPpOPEN_OUT_RAW;
11853 #  endif
11854 #  if O_TEXT != 0
11855             if (mode & O_TEXT)
11856                 o->op_private |= OPpOPEN_OUT_CRLF;
11857 #  endif
11858         }
11859     }
11860 #else
11861     PERL_UNUSED_CONTEXT;
11862     PERL_UNUSED_ARG(o);
11863 #endif
11864 }
11865 
11866 OP *
Perl_ck_backtick(pTHX_ OP * o)11867 Perl_ck_backtick(pTHX_ OP *o)
11868 {
11869     GV *gv;
11870     OP *newop = NULL;
11871     OP *sibl;
11872     PERL_ARGS_ASSERT_CK_BACKTICK;
11873     o = ck_fun(o);
11874     /* qx and `` have a null pushmark; CORE::readpipe has only one kid. */
11875     if (o->op_flags & OPf_KIDS && (sibl = OpSIBLING(cUNOPo->op_first))
11876      && (gv = gv_override("readpipe",8)))
11877     {
11878         /* detach rest of siblings from o and its first child */
11879         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
11880         newop = S_new_entersubop(aTHX_ gv, sibl);
11881     }
11882     else if (!(o->op_flags & OPf_KIDS))
11883         newop = newUNOP(OP_BACKTICK, 0,	newDEFSVOP());
11884     if (newop) {
11885         op_free(o);
11886         return newop;
11887     }
11888     S_io_hints(aTHX_ o);
11889     return o;
11890 }
11891 
11892 OP *
Perl_ck_bitop(pTHX_ OP * o)11893 Perl_ck_bitop(pTHX_ OP *o)
11894 {
11895     PERL_ARGS_ASSERT_CK_BITOP;
11896 
11897     /* get rid of arg count and indicate if in the scope of 'use integer' */
11898     o->op_private = (PL_hints & HINT_INTEGER) ? OPpUSEINT : 0;
11899 
11900     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
11901             && OP_IS_INFIX_BIT(o->op_type))
11902     {
11903         const OP * const left = cBINOPo->op_first;
11904         const OP * const right = OpSIBLING(left);
11905         if ((OP_IS_NUMCOMPARE(left->op_type) &&
11906                 (left->op_flags & OPf_PARENS) == 0) ||
11907             (OP_IS_NUMCOMPARE(right->op_type) &&
11908                 (right->op_flags & OPf_PARENS) == 0))
11909             Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
11910                           "Possible precedence problem on bitwise %s operator",
11911                            o->op_type ==  OP_BIT_OR
11912                          ||o->op_type == OP_NBIT_OR  ? "|"
11913                         :  o->op_type ==  OP_BIT_AND
11914                          ||o->op_type == OP_NBIT_AND ? "&"
11915                         :  o->op_type ==  OP_BIT_XOR
11916                          ||o->op_type == OP_NBIT_XOR ? "^"
11917                         :  o->op_type == OP_SBIT_OR  ? "|."
11918                         :  o->op_type == OP_SBIT_AND ? "&." : "^."
11919                            );
11920     }
11921     return o;
11922 }
11923 
11924 PERL_STATIC_INLINE bool
is_dollar_bracket(pTHX_ const OP * const o)11925 is_dollar_bracket(pTHX_ const OP * const o)
11926 {
11927     const OP *kid;
11928     PERL_UNUSED_CONTEXT;
11929     return o->op_type == OP_RV2SV && o->op_flags & OPf_KIDS
11930         && (kid = cUNOPx(o)->op_first)
11931         && kid->op_type == OP_GV
11932         && strEQ(GvNAME(cGVOPx_gv(kid)), "[");
11933 }
11934 
11935 /* for lt, gt, le, ge, eq, ne and their i_ variants */
11936 
11937 OP *
Perl_ck_cmp(pTHX_ OP * o)11938 Perl_ck_cmp(pTHX_ OP *o)
11939 {
11940     bool is_eq;
11941     bool neg;
11942     bool reverse;
11943     bool iv0;
11944     OP *indexop, *constop, *start;
11945     SV *sv;
11946     IV iv;
11947 
11948     PERL_ARGS_ASSERT_CK_CMP;
11949 
11950     is_eq = (   o->op_type == OP_EQ
11951              || o->op_type == OP_NE
11952              || o->op_type == OP_I_EQ
11953              || o->op_type == OP_I_NE);
11954 
11955     if (!is_eq && ckWARN(WARN_SYNTAX)) {
11956         const OP *kid = cUNOPo->op_first;
11957         if (kid &&
11958             (
11959                 (   is_dollar_bracket(aTHX_ kid)
11960                  && OpSIBLING(kid) && OpSIBLING(kid)->op_type == OP_CONST
11961                 )
11962              || (   kid->op_type == OP_CONST
11963                  && (kid = OpSIBLING(kid)) && is_dollar_bracket(aTHX_ kid)
11964                 )
11965            )
11966         )
11967             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11968                         "$[ used in %s (did you mean $] ?)", OP_DESC(o));
11969     }
11970 
11971     /* convert (index(...) == -1) and variations into
11972      *   (r)index/BOOL(,NEG)
11973      */
11974 
11975     reverse = FALSE;
11976 
11977     indexop = cUNOPo->op_first;
11978     constop = OpSIBLING(indexop);
11979     start = NULL;
11980     if (indexop->op_type == OP_CONST) {
11981         constop = indexop;
11982         indexop = OpSIBLING(constop);
11983         start = constop;
11984         reverse = TRUE;
11985     }
11986 
11987     if (indexop->op_type != OP_INDEX && indexop->op_type != OP_RINDEX)
11988         return o;
11989 
11990     /* ($lex = index(....)) == -1 */
11991     if (indexop->op_private & OPpTARGET_MY)
11992         return o;
11993 
11994     if (constop->op_type != OP_CONST)
11995         return o;
11996 
11997     sv = cSVOPx_sv(constop);
11998     if (!(sv && SvIOK_notUV(sv)))
11999         return o;
12000 
12001     iv = SvIVX(sv);
12002     if (iv != -1 && iv != 0)
12003         return o;
12004     iv0 = (iv == 0);
12005 
12006     if (o->op_type == OP_LT || o->op_type == OP_I_LT) {
12007         if (!(iv0 ^ reverse))
12008             return o;
12009         neg = iv0;
12010     }
12011     else if (o->op_type == OP_LE || o->op_type == OP_I_LE) {
12012         if (iv0 ^ reverse)
12013             return o;
12014         neg = !iv0;
12015     }
12016     else if (o->op_type == OP_GE || o->op_type == OP_I_GE) {
12017         if (!(iv0 ^ reverse))
12018             return o;
12019         neg = !iv0;
12020     }
12021     else if (o->op_type == OP_GT || o->op_type == OP_I_GT) {
12022         if (iv0 ^ reverse)
12023             return o;
12024         neg = iv0;
12025     }
12026     else if (o->op_type == OP_EQ || o->op_type == OP_I_EQ) {
12027         if (iv0)
12028             return o;
12029         neg = TRUE;
12030     }
12031     else {
12032         assert(o->op_type == OP_NE || o->op_type == OP_I_NE);
12033         if (iv0)
12034             return o;
12035         neg = FALSE;
12036     }
12037 
12038     indexop->op_flags &= ~OPf_PARENS;
12039     indexop->op_flags |= (o->op_flags & OPf_PARENS);
12040     indexop->op_private |= OPpTRUEBOOL;
12041     if (neg)
12042         indexop->op_private |= OPpINDEX_BOOLNEG;
12043     /* cut out the index op and free the eq,const ops */
12044     (void)op_sibling_splice(o, start, 1, NULL);
12045     op_free(o);
12046 
12047     return indexop;
12048 }
12049 
12050 
12051 OP *
Perl_ck_concat(pTHX_ OP * o)12052 Perl_ck_concat(pTHX_ OP *o)
12053 {
12054     const OP * const kid = cUNOPo->op_first;
12055 
12056     PERL_ARGS_ASSERT_CK_CONCAT;
12057     PERL_UNUSED_CONTEXT;
12058 
12059     /* reuse the padtmp returned by the concat child */
12060     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
12061             !(kUNOP->op_first->op_flags & OPf_MOD))
12062     {
12063         o->op_flags |= OPf_STACKED;
12064         o->op_private |= OPpCONCAT_NESTED;
12065     }
12066     return o;
12067 }
12068 
12069 OP *
Perl_ck_spair(pTHX_ OP * o)12070 Perl_ck_spair(pTHX_ OP *o)
12071 {
12072 
12073     PERL_ARGS_ASSERT_CK_SPAIR;
12074 
12075     if (o->op_flags & OPf_KIDS) {
12076         OP* newop;
12077         OP* kid;
12078         OP* kidkid;
12079         const OPCODE type = o->op_type;
12080         o = modkids(ck_fun(o), type);
12081         kid    = cUNOPo->op_first;
12082         kidkid = kUNOP->op_first;
12083         newop = OpSIBLING(kidkid);
12084         if (newop) {
12085             const OPCODE type = newop->op_type;
12086             if (OpHAS_SIBLING(newop))
12087                 return o;
12088             if (o->op_type == OP_REFGEN
12089              && (  type == OP_RV2CV
12090                 || (  !(newop->op_flags & OPf_PARENS)
12091                    && (  type == OP_RV2AV || type == OP_PADAV
12092                       || type == OP_RV2HV || type == OP_PADHV))))
12093                 NOOP; /* OK (allow srefgen for \@a and \%h) */
12094             else if (OP_GIMME(newop,0) != G_SCALAR)
12095                 return o;
12096         }
12097         /* excise first sibling */
12098         op_sibling_splice(kid, NULL, 1, NULL);
12099         op_free(kidkid);
12100     }
12101     /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
12102      * and OP_CHOMP into OP_SCHOMP */
12103     o->op_ppaddr = PL_ppaddr[++o->op_type];
12104     return ck_fun(o);
12105 }
12106 
12107 OP *
Perl_ck_delete(pTHX_ OP * o)12108 Perl_ck_delete(pTHX_ OP *o)
12109 {
12110     PERL_ARGS_ASSERT_CK_DELETE;
12111 
12112     o = ck_fun(o);
12113     o->op_private = 0;
12114     if (o->op_flags & OPf_KIDS) {
12115         OP * const kid = cUNOPo->op_first;
12116         switch (kid->op_type) {
12117         case OP_ASLICE:
12118             o->op_flags |= OPf_SPECIAL;
12119             /* FALLTHROUGH */
12120         case OP_HSLICE:
12121             o->op_private |= OPpSLICE;
12122             break;
12123         case OP_AELEM:
12124             o->op_flags |= OPf_SPECIAL;
12125             /* FALLTHROUGH */
12126         case OP_HELEM:
12127             break;
12128         case OP_KVASLICE:
12129             o->op_flags |= OPf_SPECIAL;
12130             /* FALLTHROUGH */
12131         case OP_KVHSLICE:
12132             o->op_private |= OPpKVSLICE;
12133             break;
12134         default:
12135             Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
12136                              "element or slice");
12137         }
12138         if (kid->op_private & OPpLVAL_INTRO)
12139             o->op_private |= OPpLVAL_INTRO;
12140         op_null(kid);
12141     }
12142     return o;
12143 }
12144 
12145 OP *
Perl_ck_eof(pTHX_ OP * o)12146 Perl_ck_eof(pTHX_ OP *o)
12147 {
12148     PERL_ARGS_ASSERT_CK_EOF;
12149 
12150     if (o->op_flags & OPf_KIDS) {
12151         OP *kid;
12152         if (cLISTOPo->op_first->op_type == OP_STUB) {
12153             OP * const newop
12154                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
12155             op_free(o);
12156             o = newop;
12157         }
12158         o = ck_fun(o);
12159         kid = cLISTOPo->op_first;
12160         if (kid->op_type == OP_RV2GV)
12161             kid->op_private |= OPpALLOW_FAKE;
12162     }
12163     return o;
12164 }
12165 
12166 
12167 OP *
Perl_ck_eval(pTHX_ OP * o)12168 Perl_ck_eval(pTHX_ OP *o)
12169 {
12170 
12171     PERL_ARGS_ASSERT_CK_EVAL;
12172 
12173     PL_hints |= HINT_BLOCK_SCOPE;
12174     if (o->op_flags & OPf_KIDS) {
12175         SVOP * const kid = cSVOPx(cUNOPo->op_first);
12176         assert(kid);
12177 
12178         if (o->op_type == OP_ENTERTRY) {
12179             LOGOP *enter;
12180 
12181             /* cut whole sibling chain free from o */
12182             op_sibling_splice(o, NULL, -1, NULL);
12183             op_free(o);
12184 
12185             enter = alloc_LOGOP(OP_ENTERTRY, NULL, NULL);
12186 
12187             /* establish postfix order */
12188             enter->op_next = (OP*)enter;
12189 
12190             o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
12191             OpTYPE_set(o, OP_LEAVETRY);
12192             enter->op_other = o;
12193             return o;
12194         }
12195         else {
12196             scalar((OP*)kid);
12197             S_set_haseval(aTHX);
12198         }
12199     }
12200     else {
12201         const U8 priv = o->op_private;
12202         op_free(o);
12203         /* the newUNOP will recursively call ck_eval(), which will handle
12204          * all the stuff at the end of this function, like adding
12205          * OP_HINTSEVAL
12206          */
12207         return newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP());
12208     }
12209     o->op_targ = (PADOFFSET)PL_hints;
12210     if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8;
12211     if ((PL_hints & HINT_LOCALIZE_HH) != 0
12212      && !(o->op_private & OPpEVAL_COPHH) && GvHV(PL_hintgv)) {
12213         /* Store a copy of %^H that pp_entereval can pick up. */
12214         HV *hh = hv_copy_hints_hv(GvHV(PL_hintgv));
12215         OP *hhop;
12216         STOREFEATUREBITSHH(hh);
12217         hhop = newSVOP(OP_HINTSEVAL, 0, MUTABLE_SV(hh));
12218         /* append hhop to only child  */
12219         op_sibling_splice(o, cUNOPo->op_first, 0, hhop);
12220 
12221         o->op_private |= OPpEVAL_HAS_HH;
12222     }
12223     if (!(o->op_private & OPpEVAL_BYTES)
12224          && FEATURE_UNIEVAL_IS_ENABLED)
12225             o->op_private |= OPpEVAL_UNICODE;
12226     return o;
12227 }
12228 
12229 OP *
Perl_ck_trycatch(pTHX_ OP * o)12230 Perl_ck_trycatch(pTHX_ OP *o)
12231 {
12232     LOGOP *enter;
12233     OP *to_free = NULL;
12234     OP *trykid, *catchkid;
12235     OP *catchroot, *catchstart;
12236 
12237     PERL_ARGS_ASSERT_CK_TRYCATCH;
12238 
12239     trykid = cUNOPo->op_first;
12240     if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) {
12241         to_free = trykid;
12242         trykid = OpSIBLING(trykid);
12243     }
12244     catchkid = OpSIBLING(trykid);
12245 
12246     assert(trykid->op_type == OP_POPTRY);
12247     assert(catchkid->op_type == OP_CATCH);
12248 
12249     /* cut whole sibling chain free from o */
12250     op_sibling_splice(o, NULL, -1, NULL);
12251     if(to_free)
12252         op_free(to_free);
12253     op_free(o);
12254 
12255     enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL);
12256 
12257     /* establish postfix order */
12258     enter->op_next = (OP*)enter;
12259 
12260     o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid);
12261     op_append_elem(OP_LINESEQ, (OP*)o, catchkid);
12262 
12263     OpTYPE_set(o, OP_LEAVETRYCATCH);
12264 
12265     /* The returned optree is actually threaded up slightly nonobviously in
12266      * terms of its ->op_next pointers.
12267      *
12268      * This way, if the tryblock dies, its retop points at the OP_CATCH, but
12269      * if it does not then its leavetry skips over that and continues
12270      * execution past it.
12271      */
12272 
12273     /* First, link up the actual body of the catch block */
12274     catchroot = OpSIBLING(cUNOPx(catchkid)->op_first);
12275     catchstart = LINKLIST(catchroot);
12276     cLOGOPx(catchkid)->op_other = catchstart;
12277 
12278     o->op_next = LINKLIST(o);
12279 
12280     /* die within try block should jump to the catch */
12281     enter->op_other = catchkid;
12282 
12283     /* after try block that doesn't die, just skip straight to leavetrycatch */
12284     trykid->op_next = o;
12285 
12286     /* after catch block, skip back up to the leavetrycatch */
12287     catchroot->op_next = o;
12288 
12289     return o;
12290 }
12291 
12292 OP *
Perl_ck_exec(pTHX_ OP * o)12293 Perl_ck_exec(pTHX_ OP *o)
12294 {
12295     PERL_ARGS_ASSERT_CK_EXEC;
12296 
12297     if (o->op_flags & OPf_STACKED) {
12298         OP *kid;
12299         o = ck_fun(o);
12300         kid = OpSIBLING(cUNOPo->op_first);
12301         if (kid->op_type == OP_RV2GV)
12302             op_null(kid);
12303     }
12304     else
12305         o = listkids(o);
12306     return o;
12307 }
12308 
12309 OP *
Perl_ck_exists(pTHX_ OP * o)12310 Perl_ck_exists(pTHX_ OP *o)
12311 {
12312     PERL_ARGS_ASSERT_CK_EXISTS;
12313 
12314     o = ck_fun(o);
12315     if (o->op_flags & OPf_KIDS) {
12316         OP * const kid = cUNOPo->op_first;
12317         if (kid->op_type == OP_ENTERSUB) {
12318             (void) ref(kid, o->op_type);
12319             if (kid->op_type != OP_RV2CV
12320                         && !(PL_parser && PL_parser->error_count))
12321                 Perl_croak(aTHX_
12322                           "exists argument is not a subroutine name");
12323             o->op_private |= OPpEXISTS_SUB;
12324         }
12325         else if (kid->op_type == OP_AELEM)
12326             o->op_flags |= OPf_SPECIAL;
12327         else if (kid->op_type != OP_HELEM)
12328             Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
12329                              "element or a subroutine");
12330         op_null(kid);
12331     }
12332     return o;
12333 }
12334 
12335 OP *
Perl_ck_helemexistsor(pTHX_ OP * o)12336 Perl_ck_helemexistsor(pTHX_ OP *o)
12337 {
12338     PERL_ARGS_ASSERT_CK_HELEMEXISTSOR;
12339 
12340     o = ck_fun(o);
12341 
12342     OP *first;
12343     if(!(o->op_flags & OPf_KIDS) ||
12344         !(first = cLOGOPo->op_first) ||
12345         first->op_type != OP_HELEM)
12346         /* As this opcode isn't currently exposed to pure-perl, only core or XS
12347          * authors are ever going to see this message. We don't need to list it
12348          * in perldiag as to do so would require documenting OP_HELEMEXISTSOR
12349          * itself
12350          */
12351         /* diag_listed_as: SKIPME */
12352         croak("OP_HELEMEXISTSOR argument is not a HASH element");
12353 
12354     OP *hvop  = cBINOPx(first)->op_first;
12355     OP *keyop = OpSIBLING(hvop);
12356     assert(!OpSIBLING(keyop));
12357 
12358     op_null(first); // null out the OP_HELEM
12359 
12360     keyop->op_next = o;
12361 
12362     return o;
12363 }
12364 
12365 OP *
Perl_ck_rvconst(pTHX_ OP * o)12366 Perl_ck_rvconst(pTHX_ OP *o)
12367 {
12368     SVOP * const kid = cSVOPx(cUNOPo->op_first);
12369 
12370     PERL_ARGS_ASSERT_CK_RVCONST;
12371 
12372     if (o->op_type == OP_RV2HV)
12373         /* rv2hv steals the bottom bit for its own uses */
12374         o->op_private &= ~OPpARG1_MASK;
12375 
12376     o->op_private |= (PL_hints & HINT_STRICT_REFS);
12377 
12378     if (kid->op_type == OP_CONST) {
12379         int iscv;
12380         GV *gv;
12381         SV * const kidsv = kid->op_sv;
12382 
12383         /* Is it a constant from cv_const_sv()? */
12384         if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
12385             return o;
12386         }
12387         if (SvTYPE(kidsv) == SVt_PVAV) return o;
12388         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
12389             const char *badthing;
12390             switch (o->op_type) {
12391             case OP_RV2SV:
12392                 badthing = "a SCALAR";
12393                 break;
12394             case OP_RV2AV:
12395                 badthing = "an ARRAY";
12396                 break;
12397             case OP_RV2HV:
12398                 badthing = "a HASH";
12399                 break;
12400             default:
12401                 badthing = NULL;
12402                 break;
12403             }
12404             if (badthing)
12405                 Perl_croak(aTHX_
12406                            "Can't use bareword (\"%" SVf "\") as %s ref while \"strict refs\" in use",
12407                            SVfARG(kidsv), badthing);
12408         }
12409         /*
12410          * This is a little tricky.  We only want to add the symbol if we
12411          * didn't add it in the lexer.  Otherwise we get duplicate strict
12412          * warnings.  But if we didn't add it in the lexer, we must at
12413          * least pretend like we wanted to add it even if it existed before,
12414          * or we get possible typo warnings.  OPpCONST_ENTERED says
12415          * whether the lexer already added THIS instance of this symbol.
12416          */
12417         iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0;
12418         gv = gv_fetchsv(kidsv,
12419                 o->op_type == OP_RV2CV
12420                         && o->op_private & OPpMAY_RETURN_CONSTANT
12421                     ? GV_NOEXPAND
12422                     : iscv | !(kid->op_private & OPpCONST_ENTERED),
12423                 iscv
12424                     ? SVt_PVCV
12425                     : o->op_type == OP_RV2SV
12426                         ? SVt_PV
12427                         : o->op_type == OP_RV2AV
12428                             ? SVt_PVAV
12429                             : o->op_type == OP_RV2HV
12430                                 ? SVt_PVHV
12431                                 : SVt_PVGV);
12432         if (gv) {
12433             if (!isGV(gv)) {
12434                 assert(iscv);
12435                 assert(SvROK(gv));
12436                 if (!(o->op_private & OPpMAY_RETURN_CONSTANT)
12437                   && SvTYPE(SvRV(gv)) != SVt_PVCV)
12438                     gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
12439             }
12440             OpTYPE_set(kid, OP_GV);
12441             SvREFCNT_dec(kid->op_sv);
12442 #ifdef USE_ITHREADS
12443             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
12444             STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
12445             kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
12446             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
12447             PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
12448 #else
12449             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
12450 #endif
12451             kid->op_private = 0;
12452             /* FAKE globs in the symbol table cause weird bugs (#77810) */
12453             SvFAKE_off(gv);
12454         }
12455     }
12456     return o;
12457 }
12458 
12459 OP *
Perl_ck_ftst(pTHX_ OP * o)12460 Perl_ck_ftst(pTHX_ OP *o)
12461 {
12462     const I32 type = o->op_type;
12463 
12464     PERL_ARGS_ASSERT_CK_FTST;
12465 
12466     if (o->op_flags & OPf_REF) {
12467         NOOP;
12468     }
12469     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
12470         SVOP * const kid = cSVOPx(cUNOPo->op_first);
12471         const OPCODE kidtype = kid->op_type;
12472 
12473         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
12474          && !kid->op_folded) {
12475             if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12476                 no_bareword_filehandle(SvPVX(kSVOP_sv));
12477             }
12478             OP * const newop = newGVOP(type, OPf_REF,
12479                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
12480             op_free(o);
12481             return newop;
12482         }
12483 
12484         if ((kidtype == OP_RV2AV || kidtype == OP_PADAV) && ckWARN(WARN_SYNTAX)) {
12485             SV *name = S_op_varname_subscript(aTHX_ (OP*)kid, 2);
12486             if (name) {
12487                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12488                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s (did you want stat %" SVf "?)",
12489                             array_passed_to_stat, name);
12490             }
12491             else {
12492                 /* diag_listed_as: Array passed to stat will be coerced to a scalar%s */
12493                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%s", array_passed_to_stat);
12494             }
12495        }
12496         scalar((OP *) kid);
12497         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
12498             o->op_private |= OPpFT_ACCESS;
12499         if (OP_IS_FILETEST(type)
12500             && OP_IS_FILETEST(kidtype)
12501         ) {
12502             o->op_private |= OPpFT_STACKED;
12503             kid->op_private |= OPpFT_STACKING;
12504             if (kidtype == OP_FTTTY && (
12505                    !(kid->op_private & OPpFT_STACKED)
12506                 || kid->op_private & OPpFT_AFTER_t
12507                ))
12508                 o->op_private |= OPpFT_AFTER_t;
12509         }
12510     }
12511     else {
12512         op_free(o);
12513         if (type == OP_FTTTY)
12514             o = newGVOP(type, OPf_REF, PL_stdingv);
12515         else
12516             o = newUNOP(type, 0, newDEFSVOP());
12517     }
12518     return o;
12519 }
12520 
12521 OP *
Perl_ck_fun(pTHX_ OP * o)12522 Perl_ck_fun(pTHX_ OP *o)
12523 {
12524     const int type = o->op_type;
12525     I32 oa = PL_opargs[type] >> OASHIFT;
12526 
12527     PERL_ARGS_ASSERT_CK_FUN;
12528 
12529     if (o->op_flags & OPf_STACKED) {
12530         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
12531             oa &= ~OA_OPTIONAL;
12532         else
12533             return no_fh_allowed(o);
12534     }
12535 
12536     if (o->op_flags & OPf_KIDS) {
12537         OP *prev_kid = NULL;
12538         OP *kid = cLISTOPo->op_first;
12539         I32 numargs = 0;
12540         bool seen_optional = FALSE;
12541 
12542         if (kid->op_type == OP_PUSHMARK ||
12543             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
12544         {
12545             prev_kid = kid;
12546             kid = OpSIBLING(kid);
12547         }
12548         if (kid && kid->op_type == OP_COREARGS) {
12549             bool optional = FALSE;
12550             while (oa) {
12551                 numargs++;
12552                 if (oa & OA_OPTIONAL) optional = TRUE;
12553                 oa = oa >> 4;
12554             }
12555             if (optional) o->op_private |= numargs;
12556             return o;
12557         }
12558 
12559         while (oa) {
12560             if (oa & OA_OPTIONAL || (oa & 7) == OA_LIST) {
12561                 if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV) {
12562                     kid = newDEFSVOP();
12563                     /* append kid to chain */
12564                     op_sibling_splice(o, prev_kid, 0, kid);
12565                 }
12566                 seen_optional = TRUE;
12567             }
12568             if (!kid) break;
12569 
12570             numargs++;
12571             switch (oa & 7) {
12572             case OA_SCALAR:
12573                 /* list seen where single (scalar) arg expected? */
12574                 if (numargs == 1 && !(oa >> 4)
12575                     && kid->op_type == OP_LIST && type != OP_SCALAR)
12576                 {
12577                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
12578                 }
12579                 if (type != OP_DELETE) scalar(kid);
12580                 break;
12581             case OA_LIST:
12582                 if (oa < 16) {
12583                     kid = 0;
12584                     continue;
12585                 }
12586                 else
12587                     list(kid);
12588                 break;
12589             case OA_AVREF:
12590                 if ((type == OP_PUSH || type == OP_UNSHIFT)
12591                     && !OpHAS_SIBLING(kid))
12592                     Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12593                                    "Useless use of %s with no values",
12594                                    PL_op_desc[type]);
12595 
12596                 if (kid->op_type == OP_CONST
12597                       && (  !SvROK(cSVOPx_sv(kid))
12598                          || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV  )
12599                         )
12600                     bad_type_pv(numargs, "array", o, kid);
12601                 else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
12602                          || kid->op_type == OP_RV2GV) {
12603                     bad_type_pv(1, "array", o, kid);
12604                 }
12605                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
12606                     yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
12607                                          PL_op_desc[type]), 0);
12608                 }
12609                 else {
12610                     op_lvalue(kid, type);
12611                 }
12612                 break;
12613             case OA_HVREF:
12614                 if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
12615                     bad_type_pv(numargs, "hash", o, kid);
12616                 op_lvalue(kid, type);
12617                 break;
12618             case OA_CVREF:
12619                 {
12620                     /* replace kid with newop in chain */
12621                     OP * const newop =
12622                         S_op_sibling_newUNOP(aTHX_ o, prev_kid, OP_NULL, 0);
12623                     newop->op_next = newop;
12624                     kid = newop;
12625                 }
12626                 break;
12627             case OA_FILEREF:
12628                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
12629                     if (kid->op_type == OP_CONST &&
12630                         (kid->op_private & OPpCONST_BARE))
12631                     {
12632                         OP * const newop = newGVOP(OP_GV, 0,
12633                             gv_fetchsv(kSVOP->op_sv, GV_ADD, SVt_PVIO));
12634                         /* a first argument is handled by toke.c, ideally we'd
12635                          just check here but several ops don't use ck_fun() */
12636                         if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12637                             no_bareword_filehandle(SvPVX(kSVOP_sv));
12638                         }
12639                         /* replace kid with newop in chain */
12640                         op_sibling_splice(o, prev_kid, 1, newop);
12641                         op_free(kid);
12642                         kid = newop;
12643                     }
12644                     else if (kid->op_type == OP_READLINE) {
12645                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
12646                         bad_type_pv(numargs, "HANDLE", o, kid);
12647                     }
12648                     else {
12649                         I32 flags = OPf_SPECIAL;
12650                         I32 priv = 0;
12651                         PADOFFSET targ = 0;
12652 
12653                         /* is this op a FH constructor? */
12654                         if (is_handle_constructor(o,numargs)) {
12655                             const char *name = NULL;
12656                             STRLEN len = 0;
12657                             U32 name_utf8 = 0;
12658                             bool want_dollar = TRUE;
12659 
12660                             flags = 0;
12661                             /* Set a flag to tell rv2gv to vivify
12662                              * need to "prove" flag does not mean something
12663                              * else already - NI-S 1999/05/07
12664                              */
12665                             priv = OPpDEREF;
12666                             if (kid->op_type == OP_PADSV) {
12667                                 PADNAME * const pn
12668                                     = PAD_COMPNAME_SV(kid->op_targ);
12669                                 name = PadnamePV (pn);
12670                                 len  = PadnameLEN(pn);
12671                                 name_utf8 = PadnameUTF8(pn);
12672                             }
12673                             else if (kid->op_type == OP_RV2SV
12674                                      && kUNOP->op_first->op_type == OP_GV)
12675                             {
12676                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
12677                                 name = GvNAME(gv);
12678                                 len = GvNAMELEN(gv);
12679                                 name_utf8 = GvNAMEUTF8(gv) ? SVf_UTF8 : 0;
12680                             }
12681                             else if (kid->op_type == OP_AELEM
12682                                      || kid->op_type == OP_HELEM)
12683                             {
12684                                  OP *firstop;
12685                                  OP *op = kBINOP->op_first;
12686                                  name = NULL;
12687                                  if (op) {
12688                                       SV *tmpstr = NULL;
12689                                       const char * const a =
12690                                            kid->op_type == OP_AELEM ?
12691                                            "[]" : "{}";
12692                                       if (((op->op_type == OP_RV2AV) ||
12693                                            (op->op_type == OP_RV2HV)) &&
12694                                           (firstop = cUNOPx(op)->op_first) &&
12695                                           (firstop->op_type == OP_GV)) {
12696                                            /* packagevar $a[] or $h{} */
12697                                            GV * const gv = cGVOPx_gv(firstop);
12698                                            if (gv)
12699                                                 tmpstr =
12700                                                      Perl_newSVpvf(aTHX_
12701                                                                    "%s%c...%c",
12702                                                                    GvNAME(gv),
12703                                                                    a[0], a[1]);
12704                                       }
12705                                       else if (op->op_type == OP_PADAV
12706                                                || op->op_type == OP_PADHV) {
12707                                            /* lexicalvar $a[] or $h{} */
12708                                            const char * const padname =
12709                                                 PAD_COMPNAME_PV(op->op_targ);
12710                                            if (padname)
12711                                                 tmpstr =
12712                                                      Perl_newSVpvf(aTHX_
12713                                                                    "%s%c...%c",
12714                                                                    padname + 1,
12715                                                                    a[0], a[1]);
12716                                       }
12717                                       if (tmpstr) {
12718                                            name = SvPV_const(tmpstr, len);
12719                                            name_utf8 = SvUTF8(tmpstr);
12720                                            sv_2mortal(tmpstr);
12721                                       }
12722                                  }
12723                                  if (!name) {
12724                                       name = "__ANONIO__";
12725                                       len = 10;
12726                                       want_dollar = FALSE;
12727                                  }
12728                                  op_lvalue(kid, type);
12729                             }
12730                             if (name) {
12731                                 SV *namesv;
12732                                 targ = pad_alloc(OP_RV2GV, SVf_READONLY);
12733                                 namesv = PAD_SVl(targ);
12734                                 if (want_dollar && *name != '$')
12735                                     sv_setpvs(namesv, "$");
12736                                 else
12737                                     SvPVCLEAR(namesv);
12738                                 sv_catpvn(namesv, name, len);
12739                                 if ( name_utf8 ) SvUTF8_on(namesv);
12740                             }
12741                         }
12742                         scalar(kid);
12743                         kid = S_op_sibling_newUNOP(aTHX_ o, prev_kid,
12744                                     OP_RV2GV, flags);
12745                         kid->op_targ = targ;
12746                         kid->op_private |= priv;
12747                     }
12748                 }
12749                 scalar(kid);
12750                 break;
12751             case OA_SCALARREF:
12752                 if ((type == OP_UNDEF || type == OP_POS)
12753                     && numargs == 1 && !(oa >> 4)
12754                     && kid->op_type == OP_LIST)
12755                     return too_many_arguments_pv(o,PL_op_desc[type], 0);
12756                 op_lvalue(scalar(kid), type);
12757                 break;
12758             }
12759             oa >>= 4;
12760             prev_kid = kid;
12761             kid = OpSIBLING(kid);
12762         }
12763         /* FIXME - should the numargs or-ing move after the too many
12764          * arguments check? */
12765         o->op_private |= numargs;
12766         if (kid)
12767             return too_many_arguments_pv(o,OP_DESC(o), 0);
12768         listkids(o);
12769     }
12770     else if (PL_opargs[type] & OA_DEFGV) {
12771         /* Ordering of these two is important to keep f_map.t passing.  */
12772         op_free(o);
12773         return newUNOP(type, 0, newDEFSVOP());
12774     }
12775 
12776     if (oa) {
12777         while (oa & OA_OPTIONAL)
12778             oa >>= 4;
12779         if (oa && oa != OA_LIST)
12780             return too_few_arguments_pv(o,OP_DESC(o), 0);
12781     }
12782     return o;
12783 }
12784 
12785 OP *
Perl_ck_glob(pTHX_ OP * o)12786 Perl_ck_glob(pTHX_ OP *o)
12787 {
12788     GV *gv;
12789 
12790     PERL_ARGS_ASSERT_CK_GLOB;
12791 
12792     o = ck_fun(o);
12793     if ((o->op_flags & OPf_KIDS) && !OpHAS_SIBLING(cLISTOPo->op_first))
12794         op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
12795 
12796     if (!(o->op_flags & OPf_SPECIAL) && (gv = gv_override("glob", 4)))
12797     {
12798         /* convert
12799          *     glob
12800          *       \ null - const(wildcard)
12801          * into
12802          *     null
12803          *       \ enter
12804          *            \ list
12805          *                 \ mark - glob - rv2cv
12806          *                             |        \ gv(CORE::GLOBAL::glob)
12807          *                             |
12808          *                              \ null - const(wildcard)
12809          */
12810         o->op_flags |= OPf_SPECIAL;
12811         o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
12812         o = S_new_entersubop(aTHX_ gv, o);
12813         o = newUNOP(OP_NULL, 0, o);
12814         o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
12815         return o;
12816     }
12817     else o->op_flags &= ~OPf_SPECIAL;
12818 #if !defined(PERL_EXTERNAL_GLOB)
12819     if (!PL_globhook) {
12820         ENTER;
12821         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
12822                                newSVpvs("File::Glob"), NULL, NULL, NULL);
12823         LEAVE;
12824     }
12825 #endif /* !PERL_EXTERNAL_GLOB */
12826     gv = (GV *)newSV_type(SVt_NULL);
12827     gv_init(gv, 0, "", 0, 0);
12828     gv_IOadd(gv);
12829     op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
12830     SvREFCNT_dec_NN(gv); /* newGVOP increased it */
12831     scalarkids(o);
12832     return o;
12833 }
12834 
12835 OP *
Perl_ck_grep(pTHX_ OP * o)12836 Perl_ck_grep(pTHX_ OP *o)
12837 {
12838     LOGOP *gwop;
12839     OP *kid;
12840     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
12841 
12842     PERL_ARGS_ASSERT_CK_GREP;
12843 
12844     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
12845 
12846     if (o->op_flags & OPf_STACKED) {
12847         kid = cUNOPx(OpSIBLING(cLISTOPo->op_first))->op_first;
12848         if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
12849             return no_fh_allowed(o);
12850         o->op_flags &= ~OPf_STACKED;
12851     }
12852     kid = OpSIBLING(cLISTOPo->op_first);
12853     if (type == OP_MAPWHILE)
12854         list(kid);
12855     else
12856         scalar(kid);
12857     o = ck_fun(o);
12858     if (PL_parser && PL_parser->error_count)
12859         return o;
12860     kid = OpSIBLING(cLISTOPo->op_first);
12861     if (kid->op_type != OP_NULL)
12862         Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
12863     kid = kUNOP->op_first;
12864 
12865     gwop = alloc_LOGOP(type, o, LINKLIST(kid));
12866     kid->op_next = (OP*)gwop;
12867     o->op_private = gwop->op_private = 0;
12868     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
12869 
12870     kid = OpSIBLING(cLISTOPo->op_first);
12871     for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid))
12872         op_lvalue(kid, OP_GREPSTART);
12873 
12874     return (OP*)gwop;
12875 }
12876 
12877 OP *
Perl_ck_index(pTHX_ OP * o)12878 Perl_ck_index(pTHX_ OP *o)
12879 {
12880     PERL_ARGS_ASSERT_CK_INDEX;
12881 
12882     if (o->op_flags & OPf_KIDS) {
12883         OP *kid = OpSIBLING(cLISTOPo->op_first);	/* get past pushmark */
12884         if (kid)
12885             kid = OpSIBLING(kid);			/* get past "big" */
12886         if (kid && kid->op_type == OP_CONST) {
12887             const bool save_taint = TAINT_get;
12888             SV *sv = kSVOP->op_sv;
12889             if (   (!SvPOK(sv) || SvNIOKp(sv) || isREGEXP(sv))
12890                 && SvOK(sv) && !SvROK(sv))
12891             {
12892                 sv = newSV_type(SVt_NULL);
12893                 sv_copypv(sv, kSVOP->op_sv);
12894                 SvREFCNT_dec_NN(kSVOP->op_sv);
12895                 kSVOP->op_sv = sv;
12896             }
12897             if (SvOK(sv)) fbm_compile(sv, 0);
12898             TAINT_set(save_taint);
12899 #ifdef NO_TAINT_SUPPORT
12900             PERL_UNUSED_VAR(save_taint);
12901 #endif
12902         }
12903     }
12904     return ck_fun(o);
12905 }
12906 
12907 OP *
Perl_ck_lfun(pTHX_ OP * o)12908 Perl_ck_lfun(pTHX_ OP *o)
12909 {
12910     const OPCODE type = o->op_type;
12911 
12912     PERL_ARGS_ASSERT_CK_LFUN;
12913 
12914     return modkids(ck_fun(o), type);
12915 }
12916 
12917 OP *
Perl_ck_defined(pTHX_ OP * o)12918 Perl_ck_defined(pTHX_ OP *o)		/* 19990527 MJD */
12919 {
12920     PERL_ARGS_ASSERT_CK_DEFINED;
12921 
12922     if ((o->op_flags & OPf_KIDS)) {
12923         switch (cUNOPo->op_first->op_type) {
12924         case OP_RV2AV:
12925         case OP_PADAV:
12926             Perl_croak(aTHX_ "Can't use 'defined(@array)'"
12927                              " (Maybe you should just omit the defined()?)");
12928             NOT_REACHED; /* NOTREACHED */
12929             break;
12930         case OP_RV2HV:
12931         case OP_PADHV:
12932             Perl_croak(aTHX_ "Can't use 'defined(%%hash)'"
12933                              " (Maybe you should just omit the defined()?)");
12934             NOT_REACHED; /* NOTREACHED */
12935             break;
12936         default:
12937             /* no warning */
12938             break;
12939         }
12940     }
12941     return ck_rfun(o);
12942 }
12943 
12944 OP *
Perl_ck_readline(pTHX_ OP * o)12945 Perl_ck_readline(pTHX_ OP *o)
12946 {
12947     PERL_ARGS_ASSERT_CK_READLINE;
12948 
12949     if (o->op_flags & OPf_KIDS) {
12950          OP *kid = cLISTOPo->op_first;
12951          if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED
12952              && kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
12953              no_bareword_filehandle(SvPVX(kSVOP_sv));
12954          }
12955          if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
12956          scalar(kid);
12957     }
12958     else {
12959         OP * const newop
12960             = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
12961         op_free(o);
12962         return newop;
12963     }
12964     return o;
12965 }
12966 
12967 OP *
Perl_ck_rfun(pTHX_ OP * o)12968 Perl_ck_rfun(pTHX_ OP *o)
12969 {
12970     const OPCODE type = o->op_type;
12971 
12972     PERL_ARGS_ASSERT_CK_RFUN;
12973 
12974     return refkids(ck_fun(o), type);
12975 }
12976 
12977 OP *
Perl_ck_listiob(pTHX_ OP * o)12978 Perl_ck_listiob(pTHX_ OP *o)
12979 {
12980     OP *kid;
12981 
12982     PERL_ARGS_ASSERT_CK_LISTIOB;
12983 
12984     kid = cLISTOPo->op_first;
12985     if (!kid) {
12986         o = op_force_list(o);
12987         kid = cLISTOPo->op_first;
12988     }
12989     if (kid->op_type == OP_PUSHMARK)
12990         kid = OpSIBLING(kid);
12991     if (kid && o->op_flags & OPf_STACKED)
12992         kid = OpSIBLING(kid);
12993     else if (kid && !OpHAS_SIBLING(kid)) {		/* print HANDLE; */
12994         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
12995          && !kid->op_folded) {
12996             if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
12997                 no_bareword_filehandle(SvPVX(kSVOP_sv));
12998             }
12999             o->op_flags |= OPf_STACKED;	/* make it a filehandle */
13000             scalar(kid);
13001             /* replace old const op with new OP_RV2GV parent */
13002             kid = S_op_sibling_newUNOP(aTHX_ o, cLISTOPo->op_first,
13003                                         OP_RV2GV, OPf_REF);
13004             kid = OpSIBLING(kid);
13005         }
13006     }
13007 
13008     if (!kid)
13009         op_append_elem(o->op_type, o, newDEFSVOP());
13010 
13011     if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
13012     return listkids(o);
13013 }
13014 
13015 OP *
Perl_ck_smartmatch(pTHX_ OP * o)13016 Perl_ck_smartmatch(pTHX_ OP *o)
13017 {
13018     PERL_ARGS_ASSERT_CK_SMARTMATCH;
13019     if (0 == (o->op_flags & OPf_SPECIAL)) {
13020         OP *first  = cBINOPo->op_first;
13021         OP *second = OpSIBLING(first);
13022 
13023         /* Implicitly take a reference to an array or hash */
13024 
13025         /* remove the original two siblings, then add back the
13026          * (possibly different) first and second sibs.
13027          */
13028         op_sibling_splice(o, NULL, 1, NULL);
13029         op_sibling_splice(o, NULL, 1, NULL);
13030         first  = ref_array_or_hash(first);
13031         second = ref_array_or_hash(second);
13032         op_sibling_splice(o, NULL, 0, second);
13033         op_sibling_splice(o, NULL, 0, first);
13034 
13035         /* Implicitly take a reference to a regular expression */
13036         if (first->op_type == OP_MATCH && !(first->op_flags & OPf_STACKED)) {
13037             OpTYPE_set(first, OP_QR);
13038         }
13039         if (second->op_type == OP_MATCH && !(second->op_flags & OPf_STACKED)) {
13040             OpTYPE_set(second, OP_QR);
13041         }
13042     }
13043 
13044     return o;
13045 }
13046 
13047 
13048 static OP *
S_maybe_targlex(pTHX_ OP * o)13049 S_maybe_targlex(pTHX_ OP *o)
13050 {
13051     OP * const kid = cLISTOPo->op_first;
13052     /* has a disposable target? */
13053     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
13054         && !(kid->op_flags & OPf_STACKED)
13055         /* Cannot steal the second time! */
13056         && !(kid->op_private & OPpTARGET_MY)
13057         )
13058     {
13059         OP * const kkid = OpSIBLING(kid);
13060 
13061         /* Can just relocate the target. */
13062         if (kkid && kkid->op_type == OP_PADSV
13063             && (!(kkid->op_private & OPpLVAL_INTRO)
13064                || kkid->op_private & OPpPAD_STATE))
13065         {
13066             kid->op_targ = kkid->op_targ;
13067             kkid->op_targ = 0;
13068             /* Now we do not need PADSV and SASSIGN.
13069              * Detach kid and free the rest. */
13070             op_sibling_splice(o, NULL, 1, NULL);
13071             op_free(o);
13072             kid->op_private |= OPpTARGET_MY;	/* Used for context settings */
13073             return kid;
13074         }
13075     }
13076     return o;
13077 }
13078 
13079 OP *
Perl_ck_sassign(pTHX_ OP * o)13080 Perl_ck_sassign(pTHX_ OP *o)
13081 {
13082     OP * const kid = cBINOPo->op_first;
13083 
13084     PERL_ARGS_ASSERT_CK_SASSIGN;
13085 
13086     if (OpHAS_SIBLING(kid)) {
13087         OP *kkid = OpSIBLING(kid);
13088         /* For state variable assignment with attributes, kkid is a list op
13089            whose op_last is a padsv. */
13090         if ((kkid->op_type == OP_PADSV ||
13091              (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
13092               (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
13093              )
13094             )
13095                 && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
13096                     == (OPpLVAL_INTRO|OPpPAD_STATE)) {
13097             return S_newONCEOP(aTHX_ o, kkid);
13098         }
13099     }
13100     return S_maybe_targlex(aTHX_ o);
13101 }
13102 
13103 
13104 OP *
Perl_ck_match(pTHX_ OP * o)13105 Perl_ck_match(pTHX_ OP *o)
13106 {
13107     PERL_UNUSED_CONTEXT;
13108     PERL_ARGS_ASSERT_CK_MATCH;
13109 
13110     return o;
13111 }
13112 
13113 OP *
Perl_ck_method(pTHX_ OP * o)13114 Perl_ck_method(pTHX_ OP *o)
13115 {
13116     SV *sv, *methsv, *rclass;
13117     const char* method;
13118     char* compatptr;
13119     int utf8;
13120     STRLEN len, nsplit = 0, i;
13121     OP* new_op;
13122     OP * const kid = cUNOPo->op_first;
13123 
13124     PERL_ARGS_ASSERT_CK_METHOD;
13125     if (kid->op_type != OP_CONST) return o;
13126 
13127     sv = kSVOP->op_sv;
13128 
13129     /* replace ' with :: */
13130     while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
13131                                         SvEND(sv) - SvPVX(sv) )))
13132     {
13133         *compatptr = ':';
13134         sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
13135     }
13136 
13137     method = SvPVX_const(sv);
13138     len = SvCUR(sv);
13139     utf8 = SvUTF8(sv) ? -1 : 1;
13140 
13141     for (i = len - 1; i > 0; --i) if (method[i] == ':') {
13142         nsplit = i+1;
13143         break;
13144     }
13145 
13146     methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
13147 
13148     if (!nsplit) { /* $proto->method() */
13149         op_free(o);
13150         return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
13151     }
13152 
13153     if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
13154         op_free(o);
13155         return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
13156     }
13157 
13158     /* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
13159     if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
13160         rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
13161         new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
13162     } else {
13163         rclass = newSVpvn_share(method, utf8*(nsplit-2), 0);
13164         new_op = newMETHOP_named(OP_METHOD_REDIR, 0, methsv);
13165     }
13166 #ifdef USE_ITHREADS
13167     op_relocate_sv(&rclass, &cMETHOPx(new_op)->op_rclass_targ);
13168 #else
13169     cMETHOPx(new_op)->op_rclass_sv = rclass;
13170 #endif
13171     op_free(o);
13172     return new_op;
13173 }
13174 
13175 OP *
Perl_ck_null(pTHX_ OP * o)13176 Perl_ck_null(pTHX_ OP *o)
13177 {
13178     PERL_ARGS_ASSERT_CK_NULL;
13179     PERL_UNUSED_CONTEXT;
13180     return o;
13181 }
13182 
13183 OP *
Perl_ck_open(pTHX_ OP * o)13184 Perl_ck_open(pTHX_ OP *o)
13185 {
13186     PERL_ARGS_ASSERT_CK_OPEN;
13187 
13188     S_io_hints(aTHX_ o);
13189     {
13190          /* In case of three-arg dup open remove strictness
13191           * from the last arg if it is a bareword. */
13192          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
13193          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
13194          OP *oa;
13195          const char *mode;
13196 
13197          if ((last->op_type == OP_CONST) &&		/* The bareword. */
13198              (last->op_private & OPpCONST_BARE) &&
13199              (last->op_private & OPpCONST_STRICT) &&
13200              (oa = OpSIBLING(first)) &&		/* The fh. */
13201              (oa = OpSIBLING(oa)) &&			/* The mode. */
13202              (oa->op_type == OP_CONST) &&
13203              SvPOK(cSVOPx(oa)->op_sv) &&
13204              (mode = SvPVX_const(cSVOPx(oa)->op_sv)) &&
13205              mode[0] == '>' && mode[1] == '&' &&	/* A dup open. */
13206              (last == OpSIBLING(oa)))			/* The bareword. */
13207               last->op_private &= ~OPpCONST_STRICT;
13208     }
13209     return ck_fun(o);
13210 }
13211 
13212 OP *
Perl_ck_prototype(pTHX_ OP * o)13213 Perl_ck_prototype(pTHX_ OP *o)
13214 {
13215     PERL_ARGS_ASSERT_CK_PROTOTYPE;
13216     if (!(o->op_flags & OPf_KIDS)) {
13217         op_free(o);
13218         return newUNOP(OP_PROTOTYPE, 0, newDEFSVOP());
13219     }
13220     return o;
13221 }
13222 
13223 OP *
Perl_ck_refassign(pTHX_ OP * o)13224 Perl_ck_refassign(pTHX_ OP *o)
13225 {
13226     OP * const right = cLISTOPo->op_first;
13227     OP * const left = OpSIBLING(right);
13228     OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
13229     bool stacked = 0;
13230 
13231     PERL_ARGS_ASSERT_CK_REFASSIGN;
13232     assert (left);
13233     assert (left->op_type == OP_SREFGEN);
13234 
13235     o->op_private = 0;
13236     /* we use OPpPAD_STATE in refassign to mean either of those things,
13237      * and the code assumes the two flags occupy the same bit position
13238      * in the various ops below */
13239     assert(OPpPAD_STATE == OPpOUR_INTRO);
13240 
13241     switch (varop->op_type) {
13242     case OP_PADAV:
13243         o->op_private |= OPpLVREF_AV;
13244         goto settarg;
13245     case OP_PADHV:
13246         o->op_private |= OPpLVREF_HV;
13247         /* FALLTHROUGH */
13248     case OP_PADSV:
13249       settarg:
13250         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE));
13251         o->op_targ = varop->op_targ;
13252         varop->op_targ = 0;
13253         PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
13254         break;
13255 
13256     case OP_RV2AV:
13257         o->op_private |= OPpLVREF_AV;
13258         goto checkgv;
13259         NOT_REACHED; /* NOTREACHED */
13260     case OP_RV2HV:
13261         o->op_private |= OPpLVREF_HV;
13262         /* FALLTHROUGH */
13263     case OP_RV2SV:
13264       checkgv:
13265         o->op_private |= (varop->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO));
13266         if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
13267       detach_and_stack:
13268         /* Point varop to its GV kid, detached.  */
13269         varop = op_sibling_splice(varop, NULL, -1, NULL);
13270         stacked = TRUE;
13271         break;
13272     case OP_RV2CV: {
13273         OP * const kidparent =
13274             OpSIBLING(cUNOPx(cUNOPx(varop)->op_first)->op_first);
13275         OP * const kid = cUNOPx(kidparent)->op_first;
13276         o->op_private |= OPpLVREF_CV;
13277         if (kid->op_type == OP_GV) {
13278             SV *sv = (SV*)cGVOPx_gv(kid);
13279             varop = kidparent;
13280             if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
13281                 /* a CVREF here confuses pp_refassign, so make sure
13282                    it gets a GV */
13283                 CV *const cv = (CV*)SvRV(sv);
13284                 SV *name_sv = newSVhek_mortal(CvNAME_HEK(cv));
13285                 (void)gv_init_sv((GV*)sv, CvSTASH(cv), name_sv, 0);
13286                 assert(SvTYPE(sv) == SVt_PVGV);
13287             }
13288             goto detach_and_stack;
13289         }
13290         if (kid->op_type != OP_PADCV)	goto bad;
13291         o->op_targ = kid->op_targ;
13292         kid->op_targ = 0;
13293         break;
13294     }
13295     case OP_AELEM:
13296     case OP_HELEM:
13297         o->op_private |= (varop->op_private & OPpLVAL_INTRO);
13298         o->op_private |= OPpLVREF_ELEM;
13299         op_null(varop);
13300         stacked = TRUE;
13301         /* Detach varop.  */
13302         op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
13303         break;
13304     default:
13305       bad:
13306         /* diag_listed_as: Can't modify reference to %s in %s assignment */
13307         yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
13308                                 "assignment",
13309                                  OP_DESC(varop)));
13310         return o;
13311     }
13312     if (!FEATURE_REFALIASING_IS_ENABLED)
13313         Perl_croak(aTHX_
13314                   "Experimental aliasing via reference not enabled");
13315     Perl_ck_warner_d(aTHX_
13316                      packWARN(WARN_EXPERIMENTAL__REFALIASING),
13317                     "Aliasing via reference is experimental");
13318     if (stacked) {
13319         o->op_flags |= OPf_STACKED;
13320         op_sibling_splice(o, right, 1, varop);
13321     }
13322     else {
13323         o->op_flags &=~ OPf_STACKED;
13324         op_sibling_splice(o, right, 1, NULL);
13325     }
13326     op_free(left);
13327     return o;
13328 }
13329 
13330 OP *
Perl_ck_repeat(pTHX_ OP * o)13331 Perl_ck_repeat(pTHX_ OP *o)
13332 {
13333     PERL_ARGS_ASSERT_CK_REPEAT;
13334 
13335     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
13336         OP* kids;
13337         o->op_private |= OPpREPEAT_DOLIST;
13338         kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
13339         kids = op_force_list(kids); /* promote it to a list */
13340         op_sibling_splice(o, NULL, 0, kids); /* and add back */
13341     }
13342     else
13343         scalar(o);
13344     return o;
13345 }
13346 
13347 OP *
Perl_ck_require(pTHX_ OP * o)13348 Perl_ck_require(pTHX_ OP *o)
13349 {
13350     GV* gv;
13351 
13352     PERL_ARGS_ASSERT_CK_REQUIRE;
13353 
13354     if (o->op_flags & OPf_KIDS) {	/* Shall we supply missing .pm? */
13355         SVOP * const kid = cSVOPx(cUNOPo->op_first);
13356         U32 hash;
13357         char *s;
13358         STRLEN len;
13359         if (kid->op_type == OP_CONST) {
13360           SV * const sv = kid->op_sv;
13361           U32 const was_readonly = SvREADONLY(sv);
13362           if (kid->op_private & OPpCONST_BARE) {
13363             const char *end;
13364             HEK *hek;
13365 
13366             if (was_readonly) {
13367                 SvREADONLY_off(sv);
13368             }
13369 
13370             if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
13371 
13372             s = SvPVX(sv);
13373             len = SvCUR(sv);
13374             end = s + len;
13375             /* treat ::foo::bar as foo::bar */
13376             if (len >= 2 && s[0] == ':' && s[1] == ':')
13377                 DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
13378             if (s == end)
13379                 DIE(aTHX_ "Bareword in require maps to empty filename");
13380 
13381             for (; s < end; s++) {
13382                 if (*s == ':' && s[1] == ':') {
13383                     *s = '/';
13384                     Move(s+2, s+1, end - s - 1, char);
13385                     --end;
13386                 }
13387             }
13388             SvEND_set(sv, end);
13389             sv_catpvs(sv, ".pm");
13390             PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
13391             hek = share_hek(SvPVX(sv),
13392                             (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
13393                             hash);
13394             sv_sethek(sv, hek);
13395             unshare_hek(hek);
13396             SvFLAGS(sv) |= was_readonly;
13397           }
13398           else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)
13399                 && !SvVOK(sv)) {
13400             s = SvPV(sv, len);
13401             if (SvREFCNT(sv) > 1) {
13402                 kid->op_sv = newSVpvn_share(
13403                     s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
13404                 SvREFCNT_dec_NN(sv);
13405             }
13406             else {
13407                 HEK *hek;
13408                 if (was_readonly) SvREADONLY_off(sv);
13409                 PERL_HASH(hash, s, len);
13410                 hek = share_hek(s,
13411                                 SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
13412                                 hash);
13413                 sv_sethek(sv, hek);
13414                 unshare_hek(hek);
13415                 SvFLAGS(sv) |= was_readonly;
13416             }
13417           }
13418         }
13419     }
13420 
13421     if (!(o->op_flags & OPf_SPECIAL) /* Wasn't written as CORE::require */
13422         /* handle override, if any */
13423      && (gv = gv_override("require", 7))) {
13424         OP *kid, *newop;
13425         if (o->op_flags & OPf_KIDS) {
13426             kid = cUNOPo->op_first;
13427             op_sibling_splice(o, NULL, -1, NULL);
13428         }
13429         else {
13430             kid = newDEFSVOP();
13431         }
13432         op_free(o);
13433         newop = S_new_entersubop(aTHX_ gv, kid);
13434         return newop;
13435     }
13436 
13437     return ck_fun(o);
13438 }
13439 
13440 OP *
Perl_ck_return(pTHX_ OP * o)13441 Perl_ck_return(pTHX_ OP *o)
13442 {
13443     OP *kid;
13444 
13445     PERL_ARGS_ASSERT_CK_RETURN;
13446 
13447     kid = OpSIBLING(cLISTOPo->op_first);
13448     if (PL_compcv && CvLVALUE(PL_compcv)) {
13449         for (; kid; kid = OpSIBLING(kid))
13450             op_lvalue(kid, OP_LEAVESUBLV);
13451     }
13452 
13453     return o;
13454 }
13455 
13456 OP *
Perl_ck_select(pTHX_ OP * o)13457 Perl_ck_select(pTHX_ OP *o)
13458 {
13459     OP* kid;
13460 
13461     PERL_ARGS_ASSERT_CK_SELECT;
13462 
13463     if (o->op_flags & OPf_KIDS) {
13464         kid = OpSIBLING(cLISTOPo->op_first);     /* get past pushmark */
13465         if (kid && OpHAS_SIBLING(kid)) {
13466             OpTYPE_set(o, OP_SSELECT);
13467             o = ck_fun(o);
13468             return fold_constants(op_integerize(op_std_init(o)));
13469         }
13470     }
13471     o = ck_fun(o);
13472     kid = OpSIBLING(cLISTOPo->op_first);    /* get past pushmark */
13473     if (kid && kid->op_type == OP_RV2GV)
13474         kid->op_private &= ~HINT_STRICT_REFS;
13475     return o;
13476 }
13477 
13478 OP *
Perl_ck_shift(pTHX_ OP * o)13479 Perl_ck_shift(pTHX_ OP *o)
13480 {
13481     const I32 type = o->op_type;
13482 
13483     PERL_ARGS_ASSERT_CK_SHIFT;
13484 
13485     if (!(o->op_flags & OPf_KIDS)) {
13486         OP *argop;
13487 
13488         if (!CvUNIQUE(PL_compcv)) {
13489             o->op_flags |= OPf_SPECIAL;
13490             return o;
13491         }
13492 
13493         argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
13494         op_free(o);
13495         return newUNOP(type, 0, scalar(argop));
13496     }
13497     return scalar(ck_fun(o));
13498 }
13499 
13500 OP *
Perl_ck_sort(pTHX_ OP * o)13501 Perl_ck_sort(pTHX_ OP *o)
13502 {
13503     OP *firstkid;
13504     OP *kid;
13505     U8 stacked;
13506 
13507     PERL_ARGS_ASSERT_CK_SORT;
13508 
13509     if (o->op_flags & OPf_STACKED)
13510         simplify_sort(o);
13511     firstkid = OpSIBLING(cLISTOPo->op_first);		/* get past pushmark */
13512 
13513     if (!firstkid)
13514         return too_few_arguments_pv(o,OP_DESC(o), 0);
13515 
13516     if ((stacked = o->op_flags & OPf_STACKED)) {	/* may have been cleared */
13517         OP *kid = cUNOPx(firstkid)->op_first;		/* get past null */
13518 
13519         /* if the first arg is a code block, process it and mark sort as
13520          * OPf_SPECIAL */
13521         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
13522             LINKLIST(kid);
13523             if (kid->op_type == OP_LEAVE)
13524                     op_null(kid);			/* wipe out leave */
13525             /* Prevent execution from escaping out of the sort block. */
13526             kid->op_next = 0;
13527 
13528             /* provide scalar context for comparison function/block */
13529             kid = scalar(firstkid);
13530             kid->op_next = kid;
13531             o->op_flags |= OPf_SPECIAL;
13532         }
13533         else if (kid->op_type == OP_CONST
13534               && kid->op_private & OPpCONST_BARE) {
13535             char tmpbuf[256];
13536             STRLEN len;
13537             PADOFFSET off;
13538             const char * const name = SvPV(kSVOP_sv, len);
13539             *tmpbuf = '&';
13540             assert (len < 256);
13541             Copy(name, tmpbuf+1, len, char);
13542             off = pad_findmy_pvn(tmpbuf, len+1, 0);
13543             if (off != NOT_IN_PAD) {
13544                 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
13545                     SV * const fq =
13546                         newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
13547                     sv_catpvs(fq, "::");
13548                     sv_catsv(fq, kSVOP_sv);
13549                     SvREFCNT_dec_NN(kSVOP_sv);
13550                     kSVOP->op_sv = fq;
13551                 }
13552                 else {
13553                     /* replace the const op with the pad op */
13554                     op_sibling_splice(firstkid, NULL, 1,
13555                         newPADxVOP(OP_PADCV, 0, off));
13556                     op_free(kid);
13557                 }
13558             }
13559         }
13560 
13561         firstkid = OpSIBLING(firstkid);
13562     }
13563 
13564     for (kid = firstkid; kid; kid = OpSIBLING(kid)) {
13565         /* provide list context for arguments */
13566         list(kid);
13567         if (stacked)
13568             op_lvalue(kid, OP_GREPSTART);
13569     }
13570 
13571     return o;
13572 }
13573 
13574 /* for sort { X } ..., where X is one of
13575  *   $a <=> $b, $b <=> $a, $a cmp $b, $b cmp $a
13576  * elide the second child of the sort (the one containing X),
13577  * and set these flags as appropriate
13578         OPpSORT_NUMERIC;
13579         OPpSORT_INTEGER;
13580         OPpSORT_DESCEND;
13581  * Also, check and warn on lexical $a, $b.
13582  */
13583 
13584 STATIC void
S_simplify_sort(pTHX_ OP * o)13585 S_simplify_sort(pTHX_ OP *o)
13586 {
13587     OP *kid = OpSIBLING(cLISTOPo->op_first);	/* get past pushmark */
13588     OP *k;
13589     int descending;
13590     GV *gv;
13591     const char *gvname;
13592     bool have_scopeop;
13593 
13594     PERL_ARGS_ASSERT_SIMPLIFY_SORT;
13595 
13596     kid = kUNOP->op_first;				/* get past null */
13597     if (!(have_scopeop = kid->op_type == OP_SCOPE)
13598      && kid->op_type != OP_LEAVE)
13599         return;
13600     kid = kLISTOP->op_last;				/* get past scope */
13601     switch(kid->op_type) {
13602         case OP_NCMP:
13603         case OP_I_NCMP:
13604         case OP_SCMP:
13605             if (!have_scopeop) goto padkids;
13606             break;
13607         default:
13608             return;
13609     }
13610     k = kid;						/* remember this node*/
13611     if (kBINOP->op_first->op_type != OP_RV2SV
13612      || kBINOP->op_last ->op_type != OP_RV2SV)
13613     {
13614         /*
13615            Warn about my($a) or my($b) in a sort block, *if* $a or $b is
13616            then used in a comparison.  This catches most, but not
13617            all cases.  For instance, it catches
13618                sort { my($a); $a <=> $b }
13619            but not
13620                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
13621            (although why you'd do that is anyone's guess).
13622         */
13623 
13624        padkids:
13625         if (!ckWARN(WARN_SYNTAX)) return;
13626         kid = kBINOP->op_first;
13627         do {
13628             if (kid->op_type == OP_PADSV) {
13629                 PADNAME * const name = PAD_COMPNAME(kid->op_targ);
13630                 if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
13631                  && (  PadnamePV(name)[1] == 'a'
13632                     || PadnamePV(name)[1] == 'b'  ))
13633                     /* diag_listed_as: "my %s" used in sort comparison */
13634                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13635                                      "\"%s %s\" used in sort comparison",
13636                                       PadnameIsSTATE(name)
13637                                         ? "state"
13638                                         : "my",
13639                                       PadnamePV(name));
13640             }
13641         } while ((kid = OpSIBLING(kid)));
13642         return;
13643     }
13644     kid = kBINOP->op_first;				/* get past cmp */
13645     if (kUNOP->op_first->op_type != OP_GV)
13646         return;
13647     kid = kUNOP->op_first;				/* get past rv2sv */
13648     gv = kGVOP_gv;
13649     if (GvSTASH(gv) != PL_curstash)
13650         return;
13651     gvname = GvNAME(gv);
13652     if (*gvname == 'a' && gvname[1] == '\0')
13653         descending = 0;
13654     else if (*gvname == 'b' && gvname[1] == '\0')
13655         descending = 1;
13656     else
13657         return;
13658 
13659     kid = k;						/* back to cmp */
13660     /* already checked above that it is rv2sv */
13661     kid = kBINOP->op_last;				/* down to 2nd arg */
13662     if (kUNOP->op_first->op_type != OP_GV)
13663         return;
13664     kid = kUNOP->op_first;				/* get past rv2sv */
13665     gv = kGVOP_gv;
13666     if (GvSTASH(gv) != PL_curstash)
13667         return;
13668     gvname = GvNAME(gv);
13669     if ( descending
13670          ? !(*gvname == 'a' && gvname[1] == '\0')
13671          : !(*gvname == 'b' && gvname[1] == '\0'))
13672         return;
13673     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
13674     if (descending)
13675         o->op_private |= OPpSORT_DESCEND;
13676     if (k->op_type == OP_NCMP)
13677         o->op_private |= OPpSORT_NUMERIC;
13678     if (k->op_type == OP_I_NCMP)
13679         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
13680     kid = OpSIBLING(cLISTOPo->op_first);
13681     /* cut out and delete old block (second sibling) */
13682     op_sibling_splice(o, cLISTOPo->op_first, 1, NULL);
13683     op_free(kid);
13684 }
13685 
13686 OP *
Perl_ck_split(pTHX_ OP * o)13687 Perl_ck_split(pTHX_ OP *o)
13688 {
13689     OP *kid;
13690     OP *sibs;
13691 
13692     PERL_ARGS_ASSERT_CK_SPLIT;
13693 
13694     assert(o->op_type == OP_LIST);
13695 
13696     if (o->op_flags & OPf_STACKED)
13697         return no_fh_allowed(o);
13698 
13699     kid = cLISTOPo->op_first;
13700     /* delete leading NULL node, then add a CONST if no other nodes */
13701     assert(kid->op_type == OP_NULL);
13702     op_sibling_splice(o, NULL, 1,
13703         OpHAS_SIBLING(kid) ? NULL : newSVOP(OP_CONST, 0, newSVpvs(" ")));
13704     op_free(kid);
13705     kid = cLISTOPo->op_first;
13706 
13707     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
13708         /* remove match expression, and replace with new optree with
13709          * a match op at its head */
13710         op_sibling_splice(o, NULL, 1, NULL);
13711         /* pmruntime will handle split " " behavior with flag==2 */
13712         kid = pmruntime(newPMOP(OP_MATCH, 0), kid, NULL, 2, 0);
13713         op_sibling_splice(o, NULL, 0, kid);
13714     }
13715 
13716     assert(kid->op_type == OP_MATCH || kid->op_type == OP_SPLIT);
13717 
13718     if (kPMOP->op_pmflags & PMf_GLOBAL) {
13719       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
13720                      "Use of /g modifier is meaningless in split");
13721     }
13722 
13723     /* eliminate the split op, and move the match op (plus any children)
13724      * into its place, then convert the match op into a split op. i.e.
13725      *
13726      *  SPLIT                    MATCH                 SPLIT(ex-MATCH)
13727      *    |                        |                     |
13728      *  MATCH - A - B - C   =>     R - A - B - C   =>    R - A - B - C
13729      *    |                        |                     |
13730      *    R                        X - Y                 X - Y
13731      *    |
13732      *    X - Y
13733      *
13734      * (R, if it exists, will be a regcomp op)
13735      */
13736 
13737     op_sibling_splice(o, NULL, 1, NULL); /* detach match op from o */
13738     sibs = op_sibling_splice(o, NULL, -1, NULL); /* detach any other sibs */
13739     op_sibling_splice(kid, cLISTOPx(kid)->op_last, 0, sibs); /* and reattach */
13740     OpTYPE_set(kid, OP_SPLIT);
13741     kid->op_flags   = (o->op_flags | (kid->op_flags & OPf_KIDS));
13742     kid->op_private = o->op_private;
13743     op_free(o);
13744     o = kid;
13745     kid = sibs; /* kid is now the string arg of the split */
13746 
13747     if (!kid) {
13748         kid = newDEFSVOP();
13749         op_append_elem(OP_SPLIT, o, kid);
13750     }
13751     scalar(kid);
13752 
13753     kid = OpSIBLING(kid);
13754     if (!kid) {
13755         kid = newSVOP(OP_CONST, 0, newSViv(0));
13756         op_append_elem(OP_SPLIT, o, kid);
13757         o->op_private |= OPpSPLIT_IMPLIM;
13758     }
13759     scalar(kid);
13760 
13761     if (OpHAS_SIBLING(kid))
13762         return too_many_arguments_pv(o,OP_DESC(o), 0);
13763 
13764     return o;
13765 }
13766 
13767 OP *
Perl_ck_stringify(pTHX_ OP * o)13768 Perl_ck_stringify(pTHX_ OP *o)
13769 {
13770     OP * const kid = OpSIBLING(cUNOPo->op_first);
13771     PERL_ARGS_ASSERT_CK_STRINGIFY;
13772     if ((   kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
13773          || kid->op_type == OP_LC   || kid->op_type == OP_LCFIRST
13774          || kid->op_type == OP_UC   || kid->op_type == OP_UCFIRST)
13775         && !OpHAS_SIBLING(kid)) /* syntax errs can leave extra children */
13776     {
13777         op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
13778         op_free(o);
13779         return kid;
13780     }
13781     return ck_fun(o);
13782 }
13783 
13784 OP *
Perl_ck_join(pTHX_ OP * o)13785 Perl_ck_join(pTHX_ OP *o)
13786 {
13787     OP * const kid = OpSIBLING(cLISTOPo->op_first);
13788 
13789     PERL_ARGS_ASSERT_CK_JOIN;
13790 
13791     if (kid && kid->op_type == OP_MATCH) {
13792         if (ckWARN(WARN_SYNTAX)) {
13793             const REGEXP *re = PM_GETRE(kPMOP);
13794             const SV *msg = re
13795                     ? newSVpvn_flags( RX_PRECOMP_const(re), RX_PRELEN(re),
13796                                             SVs_TEMP | ( RX_UTF8(re) ? SVf_UTF8 : 0 ) )
13797                     : newSVpvs_flags( "STRING", SVs_TEMP );
13798             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
13799                         "/%" SVf "/ should probably be written as \"%" SVf "\"",
13800                         SVfARG(msg), SVfARG(msg));
13801         }
13802     }
13803     if (kid
13804      && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
13805         || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
13806         || (  kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
13807            && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
13808     {
13809         const OP * const bairn = OpSIBLING(kid); /* the list */
13810         if (bairn && !OpHAS_SIBLING(bairn) /* single-item list */
13811          && OP_GIMME(bairn,0) == G_SCALAR)
13812         {
13813             OP * const ret = op_convert_list(OP_STRINGIFY, OPf_FOLDED,
13814                                      op_sibling_splice(o, kid, 1, NULL));
13815             op_free(o);
13816             return ret;
13817         }
13818     }
13819 
13820     return ck_fun(o);
13821 }
13822 
13823 /*
13824 =for apidoc rv2cv_op_cv
13825 
13826 Examines an op, which is expected to identify a subroutine at runtime,
13827 and attempts to determine at compile time which subroutine it identifies.
13828 This is normally used during Perl compilation to determine whether
13829 a prototype can be applied to a function call.  C<cvop> is the op
13830 being considered, normally an C<rv2cv> op.  A pointer to the identified
13831 subroutine is returned, if it could be determined statically, and a null
13832 pointer is returned if it was not possible to determine statically.
13833 
13834 Currently, the subroutine can be identified statically if the RV that the
13835 C<rv2cv> is to operate on is provided by a suitable C<gv> or C<const> op.
13836 A C<gv> op is suitable if the GV's CV slot is populated.  A C<const> op is
13837 suitable if the constant value must be an RV pointing to a CV.  Details of
13838 this process may change in future versions of Perl.  If the C<rv2cv> op
13839 has the C<OPpENTERSUB_AMPER> flag set then no attempt is made to identify
13840 the subroutine statically: this flag is used to suppress compile-time
13841 magic on a subroutine call, forcing it to use default runtime behaviour.
13842 
13843 If C<flags> has the bit C<RV2CVOPCV_MARK_EARLY> set, then the handling
13844 of a GV reference is modified.  If a GV was examined and its CV slot was
13845 found to be empty, then the C<gv> op has the C<OPpEARLY_CV> flag set.
13846 If the op is not optimised away, and the CV slot is later populated with
13847 a subroutine having a prototype, that flag eventually triggers the warning
13848 "called too early to check prototype".
13849 
13850 If C<flags> has the bit C<RV2CVOPCV_RETURN_NAME_GV> set, then instead
13851 of returning a pointer to the subroutine it returns a pointer to the
13852 GV giving the most appropriate name for the subroutine in this context.
13853 Normally this is just the C<CvGV> of the subroutine, but for an anonymous
13854 (C<CvANON>) subroutine that is referenced through a GV it will be the
13855 referencing GV.  The resulting C<GV*> is cast to C<CV*> to be returned.
13856 A null pointer is returned as usual if there is no statically-determinable
13857 subroutine.
13858 
13859 =for apidoc Amnh||OPpEARLY_CV
13860 =for apidoc Amnh||OPpENTERSUB_AMPER
13861 =for apidoc Amnh||RV2CVOPCV_MARK_EARLY
13862 =for apidoc Amnh||RV2CVOPCV_RETURN_NAME_GV
13863 
13864 =cut
13865 */
13866 
13867 /* shared by toke.c:yylex */
13868 CV *
Perl_find_lexical_cv(pTHX_ PADOFFSET off)13869 Perl_find_lexical_cv(pTHX_ PADOFFSET off)
13870 {
13871     const PADNAME *name = PAD_COMPNAME(off);
13872     CV *compcv = PL_compcv;
13873     while (PadnameOUTER(name)) {
13874         compcv = CvOUTSIDE(compcv);
13875         if (LIKELY(PARENT_PAD_INDEX(name))) {
13876             name = PadlistNAMESARRAY(CvPADLIST(compcv))
13877                 [off = PARENT_PAD_INDEX(name)];
13878         }
13879         else {
13880             /* In an eval() in an inner scope like a function, the
13881                intermediate pad in the sub might not be populated with the
13882                sub.  So search harder.
13883 
13884                It is possible we won't find the name in this
13885                particular scope, but that's fine, if we don't we'll
13886                find it in some outer scope.  Finding it here will let us
13887                go back to following the PARENT_PAD_INDEX() chain.
13888             */
13889             const PADNAMELIST * const names = PadlistNAMES(CvPADLIST(compcv));
13890             PADNAME * const * const name_p = PadnamelistARRAY(names);
13891             int offset;
13892             for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) {
13893                 const PADNAME * const thisname = name_p[offset];
13894                 /* The pv is copied from the outer PADNAME to the
13895                    inner PADNAMEs so we don't need to compare the
13896                    string contents
13897                 */
13898                 if (thisname && PadnameLEN(thisname) == PadnameLEN(name)
13899                     && PadnamePV(thisname) == PadnamePV(name)) {
13900                     name = thisname;
13901                     break;
13902                 }
13903             }
13904         }
13905     }
13906     assert(!PadnameIsOUR(name));
13907     if (!PadnameIsSTATE(name) && PadnamePROTOCV(name)) {
13908         return PadnamePROTOCV(name);
13909     }
13910     return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
13911 }
13912 
13913 CV *
Perl_rv2cv_op_cv(pTHX_ OP * cvop,U32 flags)13914 Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
13915 {
13916     OP *rvop;
13917     CV *cv;
13918     GV *gv;
13919     PERL_ARGS_ASSERT_RV2CV_OP_CV;
13920     if (flags & ~RV2CVOPCV_FLAG_MASK)
13921         Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
13922     if (cvop->op_type != OP_RV2CV)
13923         return NULL;
13924     if (cvop->op_private & OPpENTERSUB_AMPER)
13925         return NULL;
13926     if (!(cvop->op_flags & OPf_KIDS))
13927         return NULL;
13928     rvop = cUNOPx(cvop)->op_first;
13929     switch (rvop->op_type) {
13930         case OP_GV: {
13931             gv = cGVOPx_gv(rvop);
13932             if (!isGV(gv)) {
13933                 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) {
13934                     cv = MUTABLE_CV(SvRV(gv));
13935                     gv = NULL;
13936                     break;
13937                 }
13938                 if (flags & RV2CVOPCV_RETURN_STUB)
13939                     return (CV *)gv;
13940                 else return NULL;
13941             }
13942             cv = GvCVu(gv);
13943             if (!cv) {
13944                 if (flags & RV2CVOPCV_MARK_EARLY)
13945                     rvop->op_private |= OPpEARLY_CV;
13946                 return NULL;
13947             }
13948         } break;
13949         case OP_CONST: {
13950             SV *rv = cSVOPx_sv(rvop);
13951             if (!SvROK(rv))
13952                 return NULL;
13953             cv = (CV*)SvRV(rv);
13954             gv = NULL;
13955         } break;
13956         case OP_PADCV: {
13957             cv = find_lexical_cv(rvop->op_targ);
13958             gv = NULL;
13959         } break;
13960         default: {
13961             return NULL;
13962         } NOT_REACHED; /* NOTREACHED */
13963     }
13964     if (SvTYPE((SV*)cv) != SVt_PVCV)
13965         return NULL;
13966     if (flags & RV2CVOPCV_RETURN_NAME_GV) {
13967         if ((!CvANON(cv) && !CvLEXICAL(cv)) || !gv)
13968             gv = CvGV(cv);
13969         return (CV*)gv;
13970     }
13971     else if (flags & RV2CVOPCV_MAYBE_NAME_GV) {
13972         if (CvLEXICAL(cv) || CvNAMED(cv))
13973             return NULL;
13974         if (!CvANON(cv) || !gv)
13975             gv = CvGV(cv);
13976         return (CV*)gv;
13977 
13978     } else {
13979         return cv;
13980     }
13981 }
13982 
13983 /*
13984 =for apidoc ck_entersub_args_list
13985 
13986 Performs the default fixup of the arguments part of an C<entersub>
13987 op tree.  This consists of applying list context to each of the
13988 argument ops.  This is the standard treatment used on a call marked
13989 with C<&>, or a method call, or a call through a subroutine reference,
13990 or any other call where the callee can't be identified at compile time,
13991 or a call where the callee has no prototype.
13992 
13993 =cut
13994 */
13995 
13996 OP *
Perl_ck_entersub_args_list(pTHX_ OP * entersubop)13997 Perl_ck_entersub_args_list(pTHX_ OP *entersubop)
13998 {
13999     OP *aop;
14000 
14001     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST;
14002 
14003     aop = cUNOPx(entersubop)->op_first;
14004     if (!OpHAS_SIBLING(aop))
14005         aop = cUNOPx(aop)->op_first;
14006     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
14007         /* skip the extra attributes->import() call implicitly added in
14008          * something like foo(my $x : bar)
14009          */
14010         if (   aop->op_type == OP_ENTERSUB
14011             && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID
14012         )
14013             continue;
14014         list(aop);
14015         op_lvalue(aop, OP_ENTERSUB);
14016     }
14017     return entersubop;
14018 }
14019 
14020 /*
14021 =for apidoc ck_entersub_args_proto
14022 
14023 Performs the fixup of the arguments part of an C<entersub> op tree
14024 based on a subroutine prototype.  This makes various modifications to
14025 the argument ops, from applying context up to inserting C<refgen> ops,
14026 and checking the number and syntactic types of arguments, as directed by
14027 the prototype.  This is the standard treatment used on a subroutine call,
14028 not marked with C<&>, where the callee can be identified at compile time
14029 and has a prototype.
14030 
14031 C<protosv> supplies the subroutine prototype to be applied to the call.
14032 It may be a normal defined scalar, of which the string value will be used.
14033 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14034 that has been cast to C<SV*>) which has a prototype.  The prototype
14035 supplied, in whichever form, does not need to match the actual callee
14036 referenced by the op tree.
14037 
14038 If the argument ops disagree with the prototype, for example by having
14039 an unacceptable number of arguments, a valid op tree is returned anyway.
14040 The error is reflected in the parser state, normally resulting in a single
14041 exception at the top level of parsing which covers all the compilation
14042 errors that occurred.  In the error message, the callee is referred to
14043 by the name defined by the C<namegv> parameter.
14044 
14045 =cut
14046 */
14047 
14048 OP *
Perl_ck_entersub_args_proto(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14049 Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14050 {
14051     STRLEN proto_len;
14052     const char *proto, *proto_end;
14053     OP *aop, *prev, *cvop, *parent;
14054     int optional = 0;
14055     I32 arg = 0;
14056     I32 contextclass = 0;
14057     const char *e = NULL;
14058     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
14059     if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
14060         Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto, "
14061                    "flags=%lx", (unsigned long) SvFLAGS(protosv));
14062     if (SvTYPE(protosv) == SVt_PVCV)
14063          proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
14064     else proto = SvPV(protosv, proto_len);
14065     proto = S_strip_spaces(aTHX_ proto, &proto_len);
14066     proto_end = proto + proto_len;
14067     parent = entersubop;
14068     aop = cUNOPx(entersubop)->op_first;
14069     if (!OpHAS_SIBLING(aop)) {
14070         parent = aop;
14071         aop = cUNOPx(aop)->op_first;
14072     }
14073     prev = aop;
14074     aop = OpSIBLING(aop);
14075     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14076     while (aop != cvop) {
14077         OP* o3 = aop;
14078 
14079         if (proto >= proto_end)
14080         {
14081             SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14082             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14083                                         SVfARG(namesv)), SvUTF8(namesv));
14084             return entersubop;
14085         }
14086 
14087         switch (*proto) {
14088             case ';':
14089                 optional = 1;
14090                 proto++;
14091                 continue;
14092             case '_':
14093                 /* _ must be at the end */
14094                 if (proto[1] && !memCHRs(";@%", proto[1]))
14095                     goto oops;
14096                 /* FALLTHROUGH */
14097             case '$':
14098                 proto++;
14099                 arg++;
14100                 scalar(aop);
14101                 break;
14102             case '%':
14103             case '@':
14104                 list(aop);
14105                 arg++;
14106                 break;
14107             case '&':
14108                 proto++;
14109                 arg++;
14110                 if (    o3->op_type != OP_UNDEF
14111                     && o3->op_type != OP_ANONCODE
14112                     && (o3->op_type != OP_SREFGEN
14113                         || (  cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14114                                 != OP_ANONCODE
14115                             && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
14116                                 != OP_RV2CV)))
14117                     bad_type_gv(arg, namegv, o3,
14118                             arg == 1 ? "block or sub {}" : "sub {}");
14119                 break;
14120             case '*':
14121                 /* '*' allows any scalar type, including bareword */
14122                 proto++;
14123                 arg++;
14124                 if (o3->op_type == OP_RV2GV)
14125                     goto wrapref;	/* autoconvert GLOB -> GLOBref */
14126                 else if (o3->op_type == OP_CONST)
14127                     o3->op_private &= ~OPpCONST_STRICT;
14128                 scalar(aop);
14129                 break;
14130             case '+':
14131                 proto++;
14132                 arg++;
14133                 if (o3->op_type == OP_RV2AV ||
14134                     o3->op_type == OP_PADAV ||
14135                     o3->op_type == OP_RV2HV ||
14136                     o3->op_type == OP_PADHV
14137                 ) {
14138                     goto wrapref;
14139                 }
14140                 scalar(aop);
14141                 break;
14142             case '[': case ']':
14143                 goto oops;
14144 
14145             case '\\':
14146                 proto++;
14147                 arg++;
14148             again:
14149                 switch (*proto++) {
14150                     case '[':
14151                         if (contextclass++ == 0) {
14152                             e = (char *) memchr(proto, ']', proto_end - proto);
14153                             if (!e || e == proto)
14154                                 goto oops;
14155                         }
14156                         else
14157                             goto oops;
14158                         goto again;
14159 
14160                     case ']':
14161                         if (contextclass) {
14162                             const char *p = proto;
14163                             const char *const end = proto;
14164                             contextclass = 0;
14165                             while (*--p != '[')
14166                                 /* \[$] accepts any scalar lvalue */
14167                                 if (*p == '$'
14168                                  && Perl_op_lvalue_flags(aTHX_
14169                                      scalar(o3),
14170                                      OP_READ, /* not entersub */
14171                                      OP_LVALUE_NO_CROAK
14172                                     )) goto wrapref;
14173                             bad_type_gv(arg, namegv, o3,
14174                                     Perl_form(aTHX_ "one of %.*s",(int)(end - p), p));
14175                         } else
14176                             goto oops;
14177                         break;
14178                     case '*':
14179                         if (o3->op_type == OP_RV2GV)
14180                             goto wrapref;
14181                         if (!contextclass)
14182                             bad_type_gv(arg, namegv, o3, "symbol");
14183                         break;
14184                     case '&':
14185                         if (o3->op_type == OP_ENTERSUB
14186                          && !(o3->op_flags & OPf_STACKED))
14187                             goto wrapref;
14188                         if (!contextclass)
14189                             bad_type_gv(arg, namegv, o3, "subroutine");
14190                         break;
14191                     case '$':
14192                         if (o3->op_type == OP_RV2SV ||
14193                                 o3->op_type == OP_PADSV ||
14194                                 o3->op_type == OP_HELEM ||
14195                                 o3->op_type == OP_AELEM)
14196                             goto wrapref;
14197                         if (!contextclass) {
14198                             /* \$ accepts any scalar lvalue */
14199                             if (Perl_op_lvalue_flags(aTHX_
14200                                     scalar(o3),
14201                                     OP_READ,  /* not entersub */
14202                                     OP_LVALUE_NO_CROAK
14203                                )) goto wrapref;
14204                             bad_type_gv(arg, namegv, o3, "scalar");
14205                         }
14206                         break;
14207                     case '@':
14208                         if (o3->op_type == OP_RV2AV ||
14209                                 o3->op_type == OP_PADAV)
14210                         {
14211                             o3->op_flags &=~ OPf_PARENS;
14212                             goto wrapref;
14213                         }
14214                         if (!contextclass)
14215                             bad_type_gv(arg, namegv, o3, "array");
14216                         break;
14217                     case '%':
14218                         if (o3->op_type == OP_RV2HV ||
14219                                 o3->op_type == OP_PADHV)
14220                         {
14221                             o3->op_flags &=~ OPf_PARENS;
14222                             goto wrapref;
14223                         }
14224                         if (!contextclass)
14225                             bad_type_gv(arg, namegv, o3, "hash");
14226                         break;
14227                     wrapref:
14228                             aop = S_op_sibling_newUNOP(aTHX_ parent, prev,
14229                                                 OP_REFGEN, 0);
14230                         if (contextclass && e) {
14231                             proto = e + 1;
14232                             contextclass = 0;
14233                         }
14234                         break;
14235                     default: goto oops;
14236                 }
14237                 if (contextclass)
14238                     goto again;
14239                 break;
14240             case ' ':
14241                 proto++;
14242                 continue;
14243             default:
14244             oops: {
14245                 Perl_croak(aTHX_ "Malformed prototype for %" SVf ": %" SVf,
14246                                   SVfARG(cv_name((CV *)namegv, NULL, 0)),
14247                                   SVfARG(protosv));
14248             }
14249         }
14250 
14251         op_lvalue(aop, OP_ENTERSUB);
14252         prev = aop;
14253         aop = OpSIBLING(aop);
14254     }
14255     if (aop == cvop && *proto == '_') {
14256         /* generate an access to $_ */
14257         op_sibling_splice(parent, prev, 0, newDEFSVOP());
14258     }
14259     if (!optional && proto_end > proto &&
14260         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
14261     {
14262         SV * const namesv = cv_name((CV *)namegv, NULL, 0);
14263         yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %" SVf,
14264                                     SVfARG(namesv)), SvUTF8(namesv));
14265     }
14266     return entersubop;
14267 }
14268 
14269 /*
14270 =for apidoc ck_entersub_args_proto_or_list
14271 
14272 Performs the fixup of the arguments part of an C<entersub> op tree either
14273 based on a subroutine prototype or using default list-context processing.
14274 This is the standard treatment used on a subroutine call, not marked
14275 with C<&>, where the callee can be identified at compile time.
14276 
14277 C<protosv> supplies the subroutine prototype to be applied to the call,
14278 or indicates that there is no prototype.  It may be a normal scalar,
14279 in which case if it is defined then the string value will be used
14280 as a prototype, and if it is undefined then there is no prototype.
14281 Alternatively, for convenience, it may be a subroutine object (a C<CV*>
14282 that has been cast to C<SV*>), of which the prototype will be used if it
14283 has one.  The prototype (or lack thereof) supplied, in whichever form,
14284 does not need to match the actual callee referenced by the op tree.
14285 
14286 If the argument ops disagree with the prototype, for example by having
14287 an unacceptable number of arguments, a valid op tree is returned anyway.
14288 The error is reflected in the parser state, normally resulting in a single
14289 exception at the top level of parsing which covers all the compilation
14290 errors that occurred.  In the error message, the callee is referred to
14291 by the name defined by the C<namegv> parameter.
14292 
14293 =cut
14294 */
14295 
14296 OP *
Perl_ck_entersub_args_proto_or_list(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14297 Perl_ck_entersub_args_proto_or_list(pTHX_ OP *entersubop,
14298         GV *namegv, SV *protosv)
14299 {
14300     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO_OR_LIST;
14301     if (SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
14302         return ck_entersub_args_proto(entersubop, namegv, protosv);
14303     else
14304         return ck_entersub_args_list(entersubop);
14305 }
14306 
14307 OP *
Perl_ck_entersub_args_core(pTHX_ OP * entersubop,GV * namegv,SV * protosv)14308 Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
14309 {
14310     IV cvflags = SvIVX(protosv);
14311     int opnum = cvflags & 0xffff;
14312     OP *aop = cUNOPx(entersubop)->op_first;
14313 
14314     PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_CORE;
14315 
14316     if (!opnum) {
14317         OP *cvop;
14318         if (!OpHAS_SIBLING(aop))
14319             aop = cUNOPx(aop)->op_first;
14320         aop = OpSIBLING(aop);
14321         for (cvop = aop; OpSIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14322         if (aop != cvop) {
14323             SV *namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14324             yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14325                 SVfARG(namesv)), SvUTF8(namesv));
14326         }
14327 
14328         op_free(entersubop);
14329         switch(cvflags >> 16) {
14330         case 'F': return newSVOP(OP_CONST, 0,
14331                                         newSVpv(CopFILE(PL_curcop),0));
14332         case 'L': return newSVOP(
14333                            OP_CONST, 0,
14334                            Perl_newSVpvf(aTHX_
14335                              "%" LINE_Tf, CopLINE(PL_curcop)
14336                            )
14337                          );
14338         case 'P': return newSVOP(OP_CONST, 0,
14339                                    (PL_curstash
14340                                      ? newSVhek(HvNAME_HEK(PL_curstash))
14341                                      : &PL_sv_undef
14342                                    )
14343                                 );
14344         }
14345         NOT_REACHED; /* NOTREACHED */
14346     }
14347     else {
14348         OP *prev, *cvop, *first, *parent;
14349         U32 flags = 0;
14350 
14351         parent = entersubop;
14352         if (!OpHAS_SIBLING(aop)) {
14353             parent = aop;
14354             aop = cUNOPx(aop)->op_first;
14355         }
14356 
14357         first = prev = aop;
14358         aop = OpSIBLING(aop);
14359         /* find last sibling */
14360         for (cvop = aop;
14361              OpHAS_SIBLING(cvop);
14362              prev = cvop, cvop = OpSIBLING(cvop))
14363             ;
14364         if (!(cvop->op_private & OPpENTERSUB_NOPAREN)
14365             /* Usually, OPf_SPECIAL on an op with no args means that it had
14366              * parens, but these have their own meaning for that flag: */
14367             && opnum != OP_VALUES && opnum != OP_KEYS && opnum != OP_EACH
14368             && opnum != OP_DELETE && opnum != OP_EXISTS)
14369                 flags |= OPf_SPECIAL;
14370         /* excise cvop from end of sibling chain */
14371         op_sibling_splice(parent, prev, 1, NULL);
14372         op_free(cvop);
14373         if (aop == cvop) aop = NULL;
14374 
14375         /* detach remaining siblings from the first sibling, then
14376          * dispose of original optree */
14377 
14378         if (aop)
14379             op_sibling_splice(parent, first, -1, NULL);
14380         op_free(entersubop);
14381 
14382         if (cvflags == (OP_ENTEREVAL | (1<<16)))
14383             flags |= OPpEVAL_BYTES <<8;
14384 
14385         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
14386         case OA_UNOP:
14387         case OA_BASEOP_OR_UNOP:
14388         case OA_FILESTATOP:
14389             if (!aop)
14390                 return newOP(opnum,flags);       /* zero args */
14391             if (aop == prev)
14392                 return newUNOP(opnum,flags,aop); /* one arg */
14393             /* too many args */
14394             /* FALLTHROUGH */
14395         case OA_BASEOP:
14396             if (aop) {
14397                 SV *namesv;
14398                 OP *nextop;
14399 
14400                 namesv = cv_name((CV *)namegv, NULL, CV_NAME_NOTQUAL);
14401                 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %" SVf,
14402                     SVfARG(namesv)), SvUTF8(namesv));
14403                 while (aop) {
14404                     nextop = OpSIBLING(aop);
14405                     op_free(aop);
14406                     aop = nextop;
14407                 }
14408 
14409             }
14410             return opnum == OP_RUNCV
14411                 ? newSVOP(OP_RUNCV, 0, &PL_sv_undef)
14412                 : newOP(opnum,0);
14413         default:
14414             return op_convert_list(opnum,0,aop);
14415         }
14416     }
14417     NOT_REACHED; /* NOTREACHED */
14418     return entersubop;
14419 }
14420 
14421 /*
14422 =for apidoc cv_get_call_checker_flags
14423 
14424 Retrieves the function that will be used to fix up a call to C<cv>.
14425 Specifically, the function is applied to an C<entersub> op tree for a
14426 subroutine call, not marked with C<&>, where the callee can be identified
14427 at compile time as C<cv>.
14428 
14429 The C-level function pointer is returned in C<*ckfun_p>, an SV argument
14430 for it is returned in C<*ckobj_p>, and control flags are returned in
14431 C<*ckflags_p>.  The function is intended to be called in this manner:
14432 
14433  entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p));
14434 
14435 In this call, C<entersubop> is a pointer to the C<entersub> op,
14436 which may be replaced by the check function, and C<namegv> supplies
14437 the name that should be used by the check function to refer
14438 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14439 It is permitted to apply the check function in non-standard situations,
14440 such as to a call to a different subroutine or to a method call.
14441 
14442 C<namegv> may not actually be a GV.  If the C<CALL_CHECKER_REQUIRE_GV>
14443 bit is clear in C<*ckflags_p>, it is permitted to pass a CV or other SV
14444 instead, anything that can be used as the first argument to L</cv_name>.
14445 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<*ckflags_p> then the
14446 check function requires C<namegv> to be a genuine GV.
14447 
14448 By default, the check function is
14449 L<Perl_ck_entersub_args_proto_or_list|/ck_entersub_args_proto_or_list>,
14450 the SV parameter is C<cv> itself, and the C<CALL_CHECKER_REQUIRE_GV>
14451 flag is clear.  This implements standard prototype processing.  It can
14452 be changed, for a particular subroutine, by L</cv_set_call_checker_flags>.
14453 
14454 If the C<CALL_CHECKER_REQUIRE_GV> bit is set in C<gflags> then it
14455 indicates that the caller only knows about the genuine GV version of
14456 C<namegv>, and accordingly the corresponding bit will always be set in
14457 C<*ckflags_p>, regardless of the check function's recorded requirements.
14458 If the C<CALL_CHECKER_REQUIRE_GV> bit is clear in C<gflags> then it
14459 indicates the caller knows about the possibility of passing something
14460 other than a GV as C<namegv>, and accordingly the corresponding bit may
14461 be either set or clear in C<*ckflags_p>, indicating the check function's
14462 recorded requirements.
14463 
14464 C<gflags> is a bitset passed into C<cv_get_call_checker_flags>, in which
14465 only the C<CALL_CHECKER_REQUIRE_GV> bit currently has a defined meaning
14466 (for which see above).  All other bits should be clear.
14467 
14468 =for apidoc Amnh||CALL_CHECKER_REQUIRE_GV
14469 
14470 =for apidoc cv_get_call_checker
14471 
14472 The original form of L</cv_get_call_checker_flags>, which does not return
14473 checker flags.  When using a checker function returned by this function,
14474 it is only safe to call it with a genuine GV as its C<namegv> argument.
14475 
14476 =cut
14477 */
14478 
14479 void
Perl_cv_get_call_checker_flags(pTHX_ CV * cv,U32 gflags,Perl_call_checker * ckfun_p,SV ** ckobj_p,U32 * ckflags_p)14480 Perl_cv_get_call_checker_flags(pTHX_ CV *cv, U32 gflags,
14481         Perl_call_checker *ckfun_p, SV **ckobj_p, U32 *ckflags_p)
14482 {
14483     MAGIC *callmg;
14484     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER_FLAGS;
14485     PERL_UNUSED_CONTEXT;
14486     callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL;
14487     if (callmg) {
14488         *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
14489         *ckobj_p = callmg->mg_obj;
14490         *ckflags_p = (callmg->mg_flags | gflags) & MGf_REQUIRE_GV;
14491     } else {
14492         *ckfun_p = Perl_ck_entersub_args_proto_or_list;
14493         *ckobj_p = (SV*)cv;
14494         *ckflags_p = gflags & MGf_REQUIRE_GV;
14495     }
14496 }
14497 
14498 void
Perl_cv_get_call_checker(pTHX_ CV * cv,Perl_call_checker * ckfun_p,SV ** ckobj_p)14499 Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
14500 {
14501     U32 ckflags;
14502     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
14503     PERL_UNUSED_CONTEXT;
14504     cv_get_call_checker_flags(cv, CALL_CHECKER_REQUIRE_GV, ckfun_p, ckobj_p,
14505         &ckflags);
14506 }
14507 
14508 /*
14509 =for apidoc cv_set_call_checker_flags
14510 
14511 Sets the function that will be used to fix up a call to C<cv>.
14512 Specifically, the function is applied to an C<entersub> op tree for a
14513 subroutine call, not marked with C<&>, where the callee can be identified
14514 at compile time as C<cv>.
14515 
14516 The C-level function pointer is supplied in C<ckfun>, an SV argument for
14517 it is supplied in C<ckobj>, and control flags are supplied in C<ckflags>.
14518 The function should be defined like this:
14519 
14520     STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj)
14521 
14522 It is intended to be called in this manner:
14523 
14524     entersubop = ckfun(aTHX_ entersubop, namegv, ckobj);
14525 
14526 In this call, C<entersubop> is a pointer to the C<entersub> op,
14527 which may be replaced by the check function, and C<namegv> supplies
14528 the name that should be used by the check function to refer
14529 to the callee of the C<entersub> op if it needs to emit any diagnostics.
14530 It is permitted to apply the check function in non-standard situations,
14531 such as to a call to a different subroutine or to a method call.
14532 
14533 C<namegv> may not actually be a GV.  For efficiency, perl may pass a
14534 CV or other SV instead.  Whatever is passed can be used as the first
14535 argument to L</cv_name>.  You can force perl to pass a GV by including
14536 C<CALL_CHECKER_REQUIRE_GV> in the C<ckflags>.
14537 
14538 C<ckflags> is a bitset, in which only the C<CALL_CHECKER_REQUIRE_GV>
14539 bit currently has a defined meaning (for which see above).  All other
14540 bits should be clear.
14541 
14542 The current setting for a particular CV can be retrieved by
14543 L</cv_get_call_checker_flags>.
14544 
14545 =for apidoc cv_set_call_checker
14546 
14547 The original form of L</cv_set_call_checker_flags>, which passes it the
14548 C<CALL_CHECKER_REQUIRE_GV> flag for backward-compatibility.  The effect
14549 of that flag setting is that the check function is guaranteed to get a
14550 genuine GV as its C<namegv> argument.
14551 
14552 =cut
14553 */
14554 
14555 void
Perl_cv_set_call_checker(pTHX_ CV * cv,Perl_call_checker ckfun,SV * ckobj)14556 Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
14557 {
14558     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER;
14559     cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV);
14560 }
14561 
14562 void
Perl_cv_set_call_checker_flags(pTHX_ CV * cv,Perl_call_checker ckfun,SV * ckobj,U32 ckflags)14563 Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
14564                                      SV *ckobj, U32 ckflags)
14565 {
14566     PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS;
14567     if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
14568         if (SvMAGICAL((SV*)cv))
14569             mg_free_type((SV*)cv, PERL_MAGIC_checkcall);
14570     } else {
14571         MAGIC *callmg;
14572         sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0);
14573         callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall);
14574         assert(callmg);
14575         if (callmg->mg_flags & MGf_REFCOUNTED) {
14576             SvREFCNT_dec(callmg->mg_obj);
14577             callmg->mg_flags &= ~MGf_REFCOUNTED;
14578         }
14579         callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
14580         callmg->mg_obj = ckobj;
14581         if (ckobj != (SV*)cv) {
14582             SvREFCNT_inc_simple_void_NN(ckobj);
14583             callmg->mg_flags |= MGf_REFCOUNTED;
14584         }
14585         callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
14586                          | (U8)(ckflags & MGf_REQUIRE_GV) | MGf_COPY;
14587     }
14588 }
14589 
14590 static void
S_entersub_alloc_targ(pTHX_ OP * const o)14591 S_entersub_alloc_targ(pTHX_ OP * const o)
14592 {
14593     o->op_targ = pad_alloc(OP_ENTERSUB, SVs_PADTMP);
14594     o->op_private |= OPpENTERSUB_HASTARG;
14595 }
14596 
14597 OP *
Perl_ck_subr(pTHX_ OP * o)14598 Perl_ck_subr(pTHX_ OP *o)
14599 {
14600     OP *aop, *cvop;
14601     CV *cv;
14602     GV *namegv;
14603     SV **const_class = NULL;
14604 
14605     PERL_ARGS_ASSERT_CK_SUBR;
14606 
14607     aop = cUNOPx(o)->op_first;
14608     if (!OpHAS_SIBLING(aop))
14609         aop = cUNOPx(aop)->op_first;
14610     aop = OpSIBLING(aop);
14611     for (cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
14612     cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
14613     namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL;
14614 
14615     o->op_private &= ~1;
14616     o->op_private |= (PL_hints & HINT_STRICT_REFS);
14617     if (PERLDB_SUB && PL_curstash != PL_debstash)
14618         o->op_private |= OPpENTERSUB_DB;
14619     switch (cvop->op_type) {
14620         case OP_RV2CV:
14621             o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
14622             op_null(cvop);
14623             break;
14624         case OP_METHOD:
14625         case OP_METHOD_NAMED:
14626         case OP_METHOD_SUPER:
14627         case OP_METHOD_REDIR:
14628         case OP_METHOD_REDIR_SUPER:
14629             o->op_flags |= OPf_REF;
14630             if (aop->op_type == OP_CONST) {
14631                 aop->op_private &= ~OPpCONST_STRICT;
14632                 const_class = &cSVOPx(aop)->op_sv;
14633             }
14634             else if (aop->op_type == OP_LIST) {
14635                 OP * const sib = OpSIBLING(cUNOPx(aop)->op_first);
14636                 if (sib && sib->op_type == OP_CONST) {
14637                     sib->op_private &= ~OPpCONST_STRICT;
14638                     const_class = &cSVOPx(sib)->op_sv;
14639                 }
14640             }
14641             /* make class name a shared cow string to speedup method calls */
14642             /* constant string might be replaced with object, f.e. bigint */
14643             if (const_class && SvPOK(*const_class)) {
14644                 STRLEN len;
14645                 const char* str = SvPV(*const_class, len);
14646                 if (len) {
14647                     SV* const shared = newSVpvn_share(
14648                         str, SvUTF8(*const_class)
14649                                     ? -(SSize_t)len : (SSize_t)len,
14650                         0
14651                     );
14652                     if (SvREADONLY(*const_class))
14653                         SvREADONLY_on(shared);
14654                     SvREFCNT_dec(*const_class);
14655                     *const_class = shared;
14656                 }
14657             }
14658             break;
14659     }
14660 
14661     if (!cv) {
14662         S_entersub_alloc_targ(aTHX_ o);
14663         return ck_entersub_args_list(o);
14664     } else {
14665         Perl_call_checker ckfun;
14666         SV *ckobj;
14667         U32 ckflags;
14668         cv_get_call_checker_flags(cv, 0, &ckfun, &ckobj, &ckflags);
14669         if (CvISXSUB(cv) || !CvROOT(cv))
14670             S_entersub_alloc_targ(aTHX_ o);
14671         if (!namegv) {
14672             /* The original call checker API guarantees that a GV will
14673                be provided with the right name.  So, if the old API was
14674                used (or the REQUIRE_GV flag was passed), we have to reify
14675                the CV’s GV, unless this is an anonymous sub.  This is not
14676                ideal for lexical subs, as its stringification will include
14677                the package.  But it is the best we can do.  */
14678             if (ckflags & CALL_CHECKER_REQUIRE_GV) {
14679                 if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv)))
14680                     namegv = CvGV(cv);
14681             }
14682             else namegv = MUTABLE_GV(cv);
14683             /* After a syntax error in a lexical sub, the cv that
14684                rv2cv_op_cv returns may be a nameless stub. */
14685             if (!namegv) return ck_entersub_args_list(o);
14686 
14687         }
14688         return ckfun(aTHX_ o, namegv, ckobj);
14689     }
14690 }
14691 
14692 OP *
Perl_ck_svconst(pTHX_ OP * o)14693 Perl_ck_svconst(pTHX_ OP *o)
14694 {
14695     SV * const sv = cSVOPo->op_sv;
14696     PERL_ARGS_ASSERT_CK_SVCONST;
14697     PERL_UNUSED_CONTEXT;
14698 #ifdef PERL_COPY_ON_WRITE
14699     /* Since the read-only flag may be used to protect a string buffer, we
14700        cannot do copy-on-write with existing read-only scalars that are not
14701        already copy-on-write scalars.  To allow $_ = "hello" to do COW with
14702        that constant, mark the constant as COWable here, if it is not
14703        already read-only. */
14704     if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
14705         SvIsCOW_on(sv);
14706         CowREFCNT(sv) = 0;
14707 # ifdef PERL_DEBUG_READONLY_COW
14708         sv_buf_to_ro(sv);
14709 # endif
14710     }
14711 #endif
14712     SvREADONLY_on(sv);
14713     return o;
14714 }
14715 
14716 OP *
Perl_ck_trunc(pTHX_ OP * o)14717 Perl_ck_trunc(pTHX_ OP *o)
14718 {
14719     PERL_ARGS_ASSERT_CK_TRUNC;
14720 
14721     if (o->op_flags & OPf_KIDS) {
14722         SVOP *kid = cSVOPx(cUNOPo->op_first);
14723 
14724         if (kid->op_type == OP_NULL)
14725             kid = cSVOPx(OpSIBLING(kid));
14726         if (kid && kid->op_type == OP_CONST &&
14727             (kid->op_private & OPpCONST_BARE) &&
14728             !kid->op_folded)
14729         {
14730             o->op_flags |= OPf_SPECIAL;
14731             kid->op_private &= ~OPpCONST_STRICT;
14732             if (!FEATURE_BAREWORD_FILEHANDLES_IS_ENABLED) {
14733                 no_bareword_filehandle(SvPVX(cSVOPx_sv(kid)));
14734             }
14735         }
14736     }
14737     return ck_fun(o);
14738 }
14739 
14740 OP *
Perl_ck_substr(pTHX_ OP * o)14741 Perl_ck_substr(pTHX_ OP *o)
14742 {
14743     PERL_ARGS_ASSERT_CK_SUBSTR;
14744 
14745     o = ck_fun(o);
14746     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
14747         OP *kid = cLISTOPo->op_first;
14748 
14749         if (kid->op_type == OP_NULL)
14750             kid = OpSIBLING(kid);
14751         if (kid)
14752             /* Historically, substr(delete $foo{bar},...) has been allowed
14753                with 4-arg substr.  Keep it working by applying entersub
14754                lvalue context.  */
14755             op_lvalue(kid, OP_ENTERSUB);
14756 
14757     }
14758     return o;
14759 }
14760 
14761 OP *
Perl_ck_tell(pTHX_ OP * o)14762 Perl_ck_tell(pTHX_ OP *o)
14763 {
14764     PERL_ARGS_ASSERT_CK_TELL;
14765     o = ck_fun(o);
14766     if (o->op_flags & OPf_KIDS) {
14767      OP *kid = cLISTOPo->op_first;
14768      if (kid->op_type == OP_NULL && OpHAS_SIBLING(kid)) kid = OpSIBLING(kid);
14769      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
14770     }
14771     return o;
14772 }
14773 
14774 PERL_STATIC_INLINE OP *
S_last_non_null_kid(OP * o)14775 S_last_non_null_kid(OP *o) {
14776     OP *last = NULL;
14777     if (cUNOPo->op_flags & OPf_KIDS) {
14778         OP *k = cLISTOPo->op_first;
14779         while (k) {
14780             if (k->op_type != OP_NULL) {
14781                 last = k;
14782             }
14783             k = OpSIBLING(k);
14784         }
14785     }
14786 
14787     return last;
14788 }
14789 
14790 OP *
Perl_ck_each(pTHX_ OP * o)14791 Perl_ck_each(pTHX_ OP *o)
14792 {
14793     OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
14794     const unsigned orig_type  = o->op_type;
14795 
14796     PERL_ARGS_ASSERT_CK_EACH;
14797 
14798     if (kid) {
14799         switch (kid->op_type) {
14800             case OP_PADHV:
14801                 break;
14802 
14803             case OP_RV2HV:
14804                 /* Catch out an anonhash here, since the behaviour might be
14805                  * confusing.
14806                  *
14807                  * The typical tree is:
14808                  *
14809                  *     rv2hv
14810                  *         scope
14811                  *             null
14812                  *             anonhash
14813                  *
14814                  * If the contents of the block is more complex you might get:
14815                  *
14816                  *     rv2hv
14817                  *         leave
14818                  *             enter
14819                  *             ...
14820                  *             anonhash
14821                  *
14822                  * Similarly for the anonlist version below.
14823                  */
14824                 if (orig_type == OP_EACH &&
14825                     ckWARN(WARN_SYNTAX) &&
14826                     (cUNOPx(kid)->op_flags & OPf_KIDS) &&
14827                     ( cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
14828                       cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
14829                     (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
14830                     /* look for last non-null kid, since we might have:
14831                        each %{ some code ; +{ anon hash } }
14832                     */
14833                     OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
14834                     if (k && k->op_type == OP_ANONHASH) {
14835                         /* diag_listed_as: each on anonymous %s will always start from the beginning */
14836                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous hash will always start from the beginning");
14837                     }
14838                 }
14839                 break;
14840             case OP_RV2AV:
14841                 if (orig_type == OP_EACH &&
14842                     ckWARN(WARN_SYNTAX) &&
14843                     (cUNOPx(kid)->op_flags & OPf_KIDS) &&
14844                     (cUNOPx(kid)->op_first->op_type == OP_SCOPE ||
14845                      cUNOPx(kid)->op_first->op_type == OP_LEAVE) &&
14846                     (cUNOPx(kid)->op_first->op_flags & OPf_KIDS)) {
14847                     OP *k = S_last_non_null_kid(cUNOPx(kid)->op_first);
14848                     if (k && k->op_type == OP_ANONLIST) {
14849                         /* diag_listed_as: each on anonymous %s will always start from the beginning */
14850                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "each on anonymous array will always start from the beginning");
14851                     }
14852                 }
14853                 /* FALLTHROUGH */
14854             case OP_PADAV:
14855                 OpTYPE_set(o, orig_type == OP_EACH ? OP_AEACH
14856                             : orig_type == OP_KEYS ? OP_AKEYS
14857                             :                        OP_AVALUES);
14858                 break;
14859             case OP_CONST:
14860                 if (kid->op_private == OPpCONST_BARE
14861                  || !SvROK(cSVOPx_sv(kid))
14862                  || (  SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
14863                     && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV  )
14864                    )
14865                     goto bad;
14866                 /* FALLTHROUGH */
14867             default:
14868                 qerror(Perl_mess(aTHX_
14869                     "Experimental %s on scalar is now forbidden",
14870                      PL_op_desc[orig_type]));
14871                bad:
14872                 bad_type_pv(1, "hash or array", o, kid);
14873                 return o;
14874         }
14875     }
14876     return ck_fun(o);
14877 }
14878 
14879 OP *
Perl_ck_length(pTHX_ OP * o)14880 Perl_ck_length(pTHX_ OP *o)
14881 {
14882     PERL_ARGS_ASSERT_CK_LENGTH;
14883 
14884     o = ck_fun(o);
14885 
14886     if (ckWARN(WARN_SYNTAX)) {
14887         const OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
14888 
14889         if (kid) {
14890             SV *name = NULL;
14891             const bool hash = kid->op_type == OP_PADHV
14892                            || kid->op_type == OP_RV2HV;
14893             switch (kid->op_type) {
14894                 case OP_PADHV:
14895                 case OP_PADAV:
14896                 case OP_RV2HV:
14897                 case OP_RV2AV:
14898                     name = op_varname(kid);
14899                     break;
14900                 default:
14901                     return o;
14902             }
14903             if (name)
14904                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14905                     "length() used on %" SVf " (did you mean \"scalar(%s%" SVf
14906                     ")\"?)",
14907                     SVfARG(name), hash ? "keys " : "", SVfARG(name)
14908                 );
14909             else if (hash)
14910      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14911                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14912                     "length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
14913             else
14914      /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
14915                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
14916                     "length() used on @array (did you mean \"scalar(@array)\"?)");
14917         }
14918     }
14919 
14920     return o;
14921 }
14922 
14923 
14924 OP *
Perl_ck_isa(pTHX_ OP * o)14925 Perl_ck_isa(pTHX_ OP *o)
14926 {
14927     OP *classop = cBINOPo->op_last;
14928 
14929     PERL_ARGS_ASSERT_CK_ISA;
14930 
14931     /* Convert barename into PV */
14932     if(classop->op_type == OP_CONST && classop->op_private & OPpCONST_BARE) {
14933         /* TODO: Optionally convert package to raw HV here */
14934         classop->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);
14935     }
14936 
14937     return o;
14938 }
14939 
14940 
14941 /* Check for in place reverse and sort assignments like "@a = reverse @a"
14942    and modify the optree to make them work inplace */
14943 
14944 STATIC void
S_inplace_aassign(pTHX_ OP * o)14945 S_inplace_aassign(pTHX_ OP *o) {
14946 
14947     OP *modop, *modop_pushmark;
14948     OP *oright;
14949     OP *oleft, *oleft_pushmark;
14950 
14951     PERL_ARGS_ASSERT_INPLACE_AASSIGN;
14952 
14953     assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
14954 
14955     assert(cUNOPo->op_first->op_type == OP_NULL);
14956     modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
14957     assert(modop_pushmark->op_type == OP_PUSHMARK);
14958     modop = OpSIBLING(modop_pushmark);
14959 
14960     if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
14961         return;
14962 
14963     /* no other operation except sort/reverse */
14964     if (OpHAS_SIBLING(modop))
14965         return;
14966 
14967     assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
14968     if (!(oright = OpSIBLING(cUNOPx(modop)->op_first))) return;
14969 
14970     if (modop->op_flags & OPf_STACKED) {
14971         /* skip sort subroutine/block */
14972         assert(oright->op_type == OP_NULL);
14973         oright = OpSIBLING(oright);
14974     }
14975 
14976     assert(OpSIBLING(cUNOPo->op_first)->op_type == OP_NULL);
14977     oleft_pushmark = cUNOPx(OpSIBLING(cUNOPo->op_first))->op_first;
14978     assert(oleft_pushmark->op_type == OP_PUSHMARK);
14979     oleft = OpSIBLING(oleft_pushmark);
14980 
14981     /* Check the lhs is an array */
14982     if (!oleft ||
14983         (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
14984         || OpHAS_SIBLING(oleft)
14985         || (oleft->op_private & OPpLVAL_INTRO)
14986     )
14987         return;
14988 
14989     /* Only one thing on the rhs */
14990     if (OpHAS_SIBLING(oright))
14991         return;
14992 
14993     /* check the array is the same on both sides */
14994     if (oleft->op_type == OP_RV2AV) {
14995         if (oright->op_type != OP_RV2AV
14996             || !cUNOPx(oright)->op_first
14997             || cUNOPx(oright)->op_first->op_type != OP_GV
14998             || cUNOPx(oleft )->op_first->op_type != OP_GV
14999             || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
15000                cGVOPx_gv(cUNOPx(oright)->op_first)
15001         )
15002             return;
15003     }
15004     else if (oright->op_type != OP_PADAV
15005         || oright->op_targ != oleft->op_targ
15006     )
15007         return;
15008 
15009     /* This actually is an inplace assignment */
15010 
15011     modop->op_private |= OPpSORT_INPLACE;
15012 
15013     /* transfer MODishness etc from LHS arg to RHS arg */
15014     oright->op_flags = oleft->op_flags;
15015 
15016     /* remove the aassign op and the lhs */
15017     op_null(o);
15018     op_null(oleft_pushmark);
15019     if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
15020         op_null(cUNOPx(oleft)->op_first);
15021     op_null(oleft);
15022 }
15023 
15024 
15025 /*
15026 =for apidoc_section $custom
15027 
15028 =for apidoc Perl_custom_op_xop
15029 Return the XOP structure for a given custom op.  This macro should be
15030 considered internal to C<OP_NAME> and the other access macros: use them instead.
15031 This macro does call a function.  Prior
15032 to 5.19.6, this was implemented as a
15033 function.
15034 
15035 =cut
15036 */
15037 
15038 
15039 /* use PERL_MAGIC_ext to call a function to free the xop structure when
15040  * freeing PL_custom_ops */
15041 
15042 static int
custom_op_register_free(pTHX_ SV * sv,MAGIC * mg)15043 custom_op_register_free(pTHX_ SV *sv, MAGIC *mg)
15044 {
15045     XOP *xop;
15046 
15047     PERL_UNUSED_ARG(mg);
15048     xop = INT2PTR(XOP *, SvIV(sv));
15049     Safefree(xop->xop_name);
15050     Safefree(xop->xop_desc);
15051     Safefree(xop);
15052     return 0;
15053 }
15054 
15055 
15056 static const MGVTBL custom_op_register_vtbl = {
15057     0,                          /* get */
15058     0,                          /* set */
15059     0,                          /* len */
15060     0,                          /* clear */
15061     custom_op_register_free,     /* free */
15062     0,                          /* copy */
15063     0,                          /* dup */
15064 #ifdef MGf_LOCAL
15065     0,                          /* local */
15066 #endif
15067 };
15068 
15069 
15070 XOPRETANY
Perl_custom_op_get_field(pTHX_ const OP * o,const xop_flags_enum field)15071 Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field)
15072 {
15073     SV *keysv;
15074     HE *he = NULL;
15075     XOP *xop;
15076 
15077     static const XOP xop_null = { 0, 0, 0, 0, 0 };
15078 
15079     PERL_ARGS_ASSERT_CUSTOM_OP_GET_FIELD;
15080     assert(o->op_type == OP_CUSTOM);
15081 
15082     /* This is wrong. It assumes a function pointer can be cast to IV,
15083      * which isn't guaranteed, but this is what the old custom OP code
15084      * did. In principle it should be safer to Copy the bytes of the
15085      * pointer into a PV: since the new interface is hidden behind
15086      * functions, this can be changed later if necessary.  */
15087     /* Change custom_op_xop if this ever happens */
15088     keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
15089 
15090     if (PL_custom_ops)
15091         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
15092 
15093     /* See if the op isn't registered, but its name *is* registered.
15094      * That implies someone is using the pre-5.14 API,where only name and
15095      * description could be registered. If so, fake up a real
15096      * registration.
15097      * We only check for an existing name, and assume no one will have
15098      * just registered a desc */
15099     if (!he && PL_custom_op_names &&
15100         (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
15101     ) {
15102         const char *pv;
15103         STRLEN l;
15104 
15105         /* XXX does all this need to be shared mem? */
15106         Newxz(xop, 1, XOP);
15107         pv = SvPV(HeVAL(he), l);
15108         XopENTRY_set(xop, xop_name, savepvn(pv, l));
15109         if (PL_custom_op_descs &&
15110             (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
15111         ) {
15112             pv = SvPV(HeVAL(he), l);
15113             XopENTRY_set(xop, xop_desc, savepvn(pv, l));
15114         }
15115         Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
15116         he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
15117         /* add magic to the SV so that the xop struct (pointed to by
15118          * SvIV(sv)) is freed. Normally a static xop is registered, but
15119          * for this backcompat hack, we've alloced one */
15120         (void)sv_magicext(HeVAL(he), NULL, PERL_MAGIC_ext,
15121                 &custom_op_register_vtbl, NULL, 0);
15122 
15123     }
15124     else {
15125         if (!he)
15126             xop = (XOP *)&xop_null;
15127         else
15128             xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
15129     }
15130 
15131     {
15132         XOPRETANY any;
15133         if(field == XOPe_xop_ptr) {
15134             any.xop_ptr = xop;
15135         } else {
15136             const U32 flags = XopFLAGS(xop);
15137             if(flags & field) {
15138                 switch(field) {
15139                 case XOPe_xop_name:
15140                     any.xop_name = xop->xop_name;
15141                     break;
15142                 case XOPe_xop_desc:
15143                     any.xop_desc = xop->xop_desc;
15144                     break;
15145                 case XOPe_xop_class:
15146                     any.xop_class = xop->xop_class;
15147                     break;
15148                 case XOPe_xop_peep:
15149                     any.xop_peep = xop->xop_peep;
15150                     break;
15151                 default:
15152                   field_panic:
15153                     Perl_croak(aTHX_
15154                         "panic: custom_op_get_field(): invalid field %d\n",
15155                         (int)field);
15156                     break;
15157                 }
15158             } else {
15159                 switch(field) {
15160                 case XOPe_xop_name:
15161                     any.xop_name = XOPd_xop_name;
15162                     break;
15163                 case XOPe_xop_desc:
15164                     any.xop_desc = XOPd_xop_desc;
15165                     break;
15166                 case XOPe_xop_class:
15167                     any.xop_class = XOPd_xop_class;
15168                     break;
15169                 case XOPe_xop_peep:
15170                     any.xop_peep = XOPd_xop_peep;
15171                     break;
15172                 default:
15173                     goto field_panic;
15174                     break;
15175                 }
15176             }
15177         }
15178         return any;
15179     }
15180 }
15181 
15182 /*
15183 =for apidoc custom_op_register
15184 Register a custom op.  See L<perlguts/"Custom Operators">.
15185 
15186 =cut
15187 */
15188 
15189 void
Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr,const XOP * xop)15190 Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
15191 {
15192     SV *keysv;
15193 
15194     PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
15195 
15196     /* see the comment in custom_op_xop */
15197     keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
15198 
15199     if (!PL_custom_ops)
15200         PL_custom_ops = newHV();
15201 
15202     if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
15203         Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
15204 }
15205 
15206 /*
15207 
15208 =for apidoc core_prototype
15209 
15210 This function assigns the prototype of the named core function to C<sv>, or
15211 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
15212 C<NULL> if the core function has no prototype.  C<code> is a code as returned
15213 by C<keyword()>.  It must not be equal to 0.
15214 
15215 =cut
15216 */
15217 
15218 SV *
Perl_core_prototype(pTHX_ SV * sv,const char * name,const int code,int * const opnum)15219 Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
15220                           int * const opnum)
15221 {
15222     int i = 0, n = 0, seen_question = 0, defgv = 0;
15223     I32 oa;
15224 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
15225     char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
15226     bool nullret = FALSE;
15227 
15228     PERL_ARGS_ASSERT_CORE_PROTOTYPE;
15229 
15230     assert (code);
15231 
15232     if (!sv) sv = sv_newmortal();
15233 
15234 #define retsetpvs(x,y) sv_setpvs(sv, x); if(opnum) *opnum=(y); return sv
15235 
15236     switch (code < 0 ? -code : code) {
15237     case KEY_and   : case KEY_chop: case KEY_chomp:
15238     case KEY_cmp   : case KEY_defined: case KEY_delete: case KEY_exec  :
15239     case KEY_exists: case KEY_eq     : case KEY_ge    : case KEY_goto  :
15240     case KEY_grep  : case KEY_gt     : case KEY_last  : case KEY_le    :
15241     case KEY_lt    : case KEY_map    : case KEY_ne    : case KEY_next  :
15242     case KEY_or    : case KEY_print  : case KEY_printf: case KEY_qr    :
15243     case KEY_redo  : case KEY_require: case KEY_return: case KEY_say   :
15244     case KEY_select: case KEY_sort   : case KEY_split : case KEY_system:
15245     case KEY_x     : case KEY_xor    :
15246         if (!opnum) return NULL; nullret = TRUE; goto findopnum;
15247     case KEY_glob:    retsetpvs("_;", OP_GLOB);
15248     case KEY_keys:    retsetpvs("\\[%@]", OP_KEYS);
15249     case KEY_values:  retsetpvs("\\[%@]", OP_VALUES);
15250     case KEY_each:    retsetpvs("\\[%@]", OP_EACH);
15251     case KEY_pos:     retsetpvs(";\\[$*]", OP_POS);
15252     case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__:
15253         retsetpvs("", 0);
15254     case KEY_evalbytes:
15255         name = "entereval"; break;
15256     case KEY_readpipe:
15257         name = "backtick";
15258     }
15259 
15260 #undef retsetpvs
15261 
15262   findopnum:
15263     while (i < MAXO) {	/* The slow way. */
15264         if (strEQ(name, PL_op_name[i])
15265             || strEQ(name, PL_op_desc[i]))
15266         {
15267             if (nullret) { assert(opnum); *opnum = i; return NULL; }
15268             goto found;
15269         }
15270         i++;
15271     }
15272     return NULL;
15273   found:
15274     defgv = PL_opargs[i] & OA_DEFGV;
15275     oa = PL_opargs[i] >> OASHIFT;
15276     while (oa) {
15277         if (oa & OA_OPTIONAL && !seen_question && (
15278               !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
15279         )) {
15280             seen_question = 1;
15281             str[n++] = ';';
15282         }
15283         if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
15284             && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
15285             /* But globs are already references (kinda) */
15286             && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
15287         ) {
15288             str[n++] = '\\';
15289         }
15290         if ((oa & (OA_OPTIONAL - 1)) == OA_SCALARREF
15291          && !scalar_mod_type(NULL, i)) {
15292             str[n++] = '[';
15293             str[n++] = '$';
15294             str[n++] = '@';
15295             str[n++] = '%';
15296             if (i == OP_LOCK || i == OP_UNDEF) str[n++] = '&';
15297             str[n++] = '*';
15298             str[n++] = ']';
15299         }
15300         else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
15301         if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
15302             str[n-1] = '_'; defgv = 0;
15303         }
15304         oa = oa >> 4;
15305     }
15306     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
15307     str[n++] = '\0';
15308     sv_setpvn(sv, str, n - 1);
15309     if (opnum) *opnum = i;
15310     return sv;
15311 }
15312 
15313 OP *
Perl_coresub_op(pTHX_ SV * const coreargssv,const int code,const int opnum)15314 Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
15315                       const int opnum)
15316 {
15317     OP * const argop = (opnum == OP_SELECT && code) ? NULL :
15318                                         newSVOP(OP_COREARGS,0,coreargssv);
15319     OP *o;
15320 
15321     PERL_ARGS_ASSERT_CORESUB_OP;
15322 
15323     switch(opnum) {
15324     case 0:
15325         return op_append_elem(OP_LINESEQ,
15326                        argop,
15327                        newSLICEOP(0,
15328                                   newSVOP(OP_CONST, 0, newSViv(-code % 3)),
15329                                   newOP(OP_CALLER,0)
15330                        )
15331                );
15332     case OP_EACH:
15333     case OP_KEYS:
15334     case OP_VALUES:
15335         o = newUNOP(OP_AVHVSWITCH,0,argop);
15336         o->op_private = opnum-OP_EACH;
15337         return o;
15338     case OP_SELECT: /* which represents OP_SSELECT as well */
15339         if (code)
15340             return newCONDOP(
15341                          0,
15342                          newBINOP(OP_GT, 0,
15343                                   newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
15344                                   newSVOP(OP_CONST, 0, newSVuv(1))
15345                                  ),
15346                          coresub_op(newSVuv((UV)OP_SSELECT), 0,
15347                                     OP_SSELECT),
15348                          coresub_op(coreargssv, 0, OP_SELECT)
15349                    );
15350         /* FALLTHROUGH */
15351     default:
15352         switch (PL_opargs[opnum] & OA_CLASS_MASK) {
15353         case OA_BASEOP:
15354             return op_append_elem(
15355                         OP_LINESEQ, argop,
15356                         newOP(opnum,
15357                               opnum == OP_WANTARRAY || opnum == OP_RUNCV
15358                                 ? OPpOFFBYONE << 8 : 0)
15359                    );
15360         case OA_BASEOP_OR_UNOP:
15361             if (opnum == OP_ENTEREVAL) {
15362                 o = newUNOP(OP_ENTEREVAL,OPpEVAL_COPHH<<8,argop);
15363                 if (code == -KEY_evalbytes) o->op_private |= OPpEVAL_BYTES;
15364             }
15365             else o = newUNOP(opnum,0,argop);
15366             if (opnum == OP_CALLER) o->op_private |= OPpOFFBYONE;
15367             else {
15368           onearg:
15369               if (is_handle_constructor(o, 1))
15370                 argop->op_private |= OPpCOREARGS_DEREF1;
15371               if (scalar_mod_type(NULL, opnum))
15372                 argop->op_private |= OPpCOREARGS_SCALARMOD;
15373             }
15374             return o;
15375         default:
15376             o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
15377             if (is_handle_constructor(o, 2))
15378                 argop->op_private |= OPpCOREARGS_DEREF2;
15379             if (opnum == OP_SUBSTR) {
15380                 o->op_private |= OPpMAYBE_LVSUB;
15381                 return o;
15382             }
15383             else goto onearg;
15384         }
15385     }
15386 }
15387 
15388 void
Perl_report_redefined_cv(pTHX_ const SV * name,const CV * old_cv,SV * const * new_const_svp)15389 Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv,
15390                                SV * const *new_const_svp)
15391 {
15392     const char *hvname;
15393     bool is_const = cBOOL(CvCONST(old_cv));
15394     SV *old_const_sv = is_const ? cv_const_sv_or_av(old_cv) : NULL;
15395 
15396     PERL_ARGS_ASSERT_REPORT_REDEFINED_CV;
15397 
15398     if (is_const && new_const_svp && old_const_sv == *new_const_svp)
15399         return;
15400         /* They are 2 constant subroutines generated from
15401            the same constant. This probably means that
15402            they are really the "same" proxy subroutine
15403            instantiated in 2 places. Most likely this is
15404            when a constant is exported twice.  Don't warn.
15405         */
15406     if (
15407         (ckWARN(WARN_REDEFINE)
15408          && !(
15409                 CvGV(old_cv) && GvSTASH(CvGV(old_cv))
15410              && HvNAMELEN(GvSTASH(CvGV(old_cv))) == 7
15411              && (hvname = HvNAME(GvSTASH(CvGV(old_cv))),
15412                  strEQ(hvname, "autouse"))
15413              )
15414         )
15415      || (is_const
15416          && ckWARN_d(WARN_REDEFINE)
15417          && (!new_const_svp ||
15418              !*new_const_svp ||
15419              !old_const_sv ||
15420              SvTYPE(old_const_sv) == SVt_PVAV ||
15421              SvTYPE(*new_const_svp) == SVt_PVAV ||
15422              sv_cmp(old_const_sv, *new_const_svp))
15423         )
15424         ) {
15425         Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
15426                           is_const
15427                             ? "Constant subroutine %" SVf " redefined"
15428                             : CvIsMETHOD(old_cv)
15429                               ? "Method %" SVf " redefined"
15430                               : "Subroutine %" SVf " redefined",
15431                           SVfARG(name));
15432     }
15433 }
15434 
15435 /*
15436 =for apidoc_section $hook
15437 
15438 These functions provide convenient and thread-safe means of manipulating
15439 hook variables.
15440 
15441 =cut
15442 */
15443 
15444 /*
15445 =for apidoc wrap_op_checker
15446 
15447 Puts a C function into the chain of check functions for a specified op
15448 type.  This is the preferred way to manipulate the L</PL_check> array.
15449 C<opcode> specifies which type of op is to be affected.  C<new_checker>
15450 is a pointer to the C function that is to be added to that opcode's
15451 check chain, and C<old_checker_p> points to the storage location where a
15452 pointer to the next function in the chain will be stored.  The value of
15453 C<new_checker> is written into the L</PL_check> array, while the value
15454 previously stored there is written to C<*old_checker_p>.
15455 
15456 L</PL_check> is global to an entire process, and a module wishing to
15457 hook op checking may find itself invoked more than once per process,
15458 typically in different threads.  To handle that situation, this function
15459 is idempotent.  The location C<*old_checker_p> must initially (once
15460 per process) contain a null pointer.  A C variable of static duration
15461 (declared at file scope, typically also marked C<static> to give
15462 it internal linkage) will be implicitly initialised appropriately,
15463 if it does not have an explicit initialiser.  This function will only
15464 actually modify the check chain if it finds C<*old_checker_p> to be null.
15465 This function is also thread safe on the small scale.  It uses appropriate
15466 locking to avoid race conditions in accessing L</PL_check>.
15467 
15468 When this function is called, the function referenced by C<new_checker>
15469 must be ready to be called, except for C<*old_checker_p> being unfilled.
15470 In a threading situation, C<new_checker> may be called immediately,
15471 even before this function has returned.  C<*old_checker_p> will always
15472 be appropriately set before C<new_checker> is called.  If C<new_checker>
15473 decides not to do anything special with an op that it is given (which
15474 is the usual case for most uses of op check hooking), it must chain the
15475 check function referenced by C<*old_checker_p>.
15476 
15477 Taken all together, XS code to hook an op checker should typically look
15478 something like this:
15479 
15480     static Perl_check_t nxck_frob;
15481     static OP *myck_frob(pTHX_ OP *op) {
15482         ...
15483         op = nxck_frob(aTHX_ op);
15484         ...
15485         return op;
15486     }
15487     BOOT:
15488         wrap_op_checker(OP_FROB, myck_frob, &nxck_frob);
15489 
15490 If you want to influence compilation of calls to a specific subroutine,
15491 then use L</cv_set_call_checker_flags> rather than hooking checking of
15492 all C<entersub> ops.
15493 
15494 =cut
15495 */
15496 
15497 void
Perl_wrap_op_checker(pTHX_ Optype opcode,Perl_check_t new_checker,Perl_check_t * old_checker_p)15498 Perl_wrap_op_checker(pTHX_ Optype opcode,
15499     Perl_check_t new_checker, Perl_check_t *old_checker_p)
15500 {
15501 
15502     PERL_UNUSED_CONTEXT;
15503     PERL_ARGS_ASSERT_WRAP_OP_CHECKER;
15504     if (*old_checker_p) return;
15505     OP_CHECK_MUTEX_LOCK;
15506     if (!*old_checker_p) {
15507         *old_checker_p = PL_check[opcode];
15508         PL_check[opcode] = new_checker;
15509     }
15510     OP_CHECK_MUTEX_UNLOCK;
15511 }
15512 
15513 #include "XSUB.h"
15514 
15515 /* Efficient sub that returns a constant scalar value. */
15516 static void
const_sv_xsub(pTHX_ CV * cv)15517 const_sv_xsub(pTHX_ CV* cv)
15518 {
15519     dXSARGS;
15520     SV *const sv = MUTABLE_SV(XSANY.any_ptr);
15521     PERL_UNUSED_ARG(items);
15522     if (!sv) {
15523         XSRETURN(0);
15524     }
15525     EXTEND(sp, 1);
15526     ST(0) = sv;
15527     XSRETURN(1);
15528 }
15529 
15530 static void
const_av_xsub(pTHX_ CV * cv)15531 const_av_xsub(pTHX_ CV* cv)
15532 {
15533     dXSARGS;
15534     AV * const av = MUTABLE_AV(XSANY.any_ptr);
15535     SP -= items;
15536     assert(av);
15537 #ifndef DEBUGGING
15538     if (!av) {
15539         XSRETURN(0);
15540     }
15541 #endif
15542     if (SvRMAGICAL(av))
15543         Perl_croak(aTHX_ "Magical list constants are not supported");
15544     if (GIMME_V != G_LIST) {
15545         EXTEND(SP, 1);
15546         ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1));
15547         XSRETURN(1);
15548     }
15549     EXTEND(SP, AvFILLp(av)+1);
15550     Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
15551     XSRETURN(AvFILLp(av)+1);
15552 }
15553 
15554 /* Copy an existing cop->cop_warnings field.
15555  * If it's one of the standard addresses, just re-use the address.
15556  * This is the e implementation for the DUP_WARNINGS() macro
15557  */
15558 
15559 char *
Perl_dup_warnings(pTHX_ char * warnings)15560 Perl_dup_warnings(pTHX_ char* warnings)
15561 {
15562     if (warnings == NULL || specialWARN(warnings))
15563         return warnings;
15564 
15565     return rcpv_copy(warnings);
15566 }
15567 
15568 /*
15569 =for apidoc rcpv_new
15570 
15571 Create a new shared memory refcounted string with the requested size, and
15572 with the requested initialization and a refcount of 1. The actual space
15573 allocated will be 1 byte more than requested and rcpv_new() will ensure that
15574 the extra byte is a null regardless of any flags settings.
15575 
15576 If the RCPVf_NO_COPY flag is set then the pv argument will be
15577 ignored, otherwise the contents of the pv pointer will be copied into
15578 the new buffer or if it is NULL the function will do nothing and return NULL.
15579 
15580 If the RCPVf_USE_STRLEN flag is set then the len argument is ignored and
15581 recomputed using C<strlen(pv)>. It is an error to combine RCPVf_USE_STRLEN
15582 and RCPVf_NO_COPY at the same time.
15583 
15584 Under DEBUGGING rcpv_new() will assert() if it is asked to create a 0 length
15585 shared string unless the RCPVf_ALLOW_EMPTY flag is set.
15586 
15587 The return value from the function is suitable for passing into rcpv_copy() and
15588 rcpv_free(). To access the RCPV * from the returned value use the RCPVx() macro.
15589 The 'len' member of the RCPV struct stores the allocated length (including the
15590 extra byte), but the RCPV_LEN() macro returns the requested length (not
15591 including the extra byte).
15592 
15593 Note that rcpv_new() does NOT use a hash table or anything like that to
15594 dedupe inputs given the same text content. Each call with a non-null pv
15595 parameter will produce a distinct pointer with its own refcount regardless of
15596 the input content.
15597 
15598 =cut
15599 */
15600 
15601 char *
Perl_rcpv_new(pTHX_ const char * pv,STRLEN len,U32 flags)15602 Perl_rcpv_new(pTHX_ const char *pv, STRLEN len, U32 flags) {
15603     RCPV *rcpv;
15604 
15605     PERL_ARGS_ASSERT_RCPV_NEW;
15606 
15607     PERL_UNUSED_CONTEXT;
15608 
15609     /* Musn't use both at the same time */
15610     assert((flags & (RCPVf_NO_COPY|RCPVf_USE_STRLEN))!=
15611                     (RCPVf_NO_COPY|RCPVf_USE_STRLEN));
15612 
15613     if (!pv && (flags & RCPVf_NO_COPY) == 0)
15614         return NULL;
15615 
15616     if (flags & RCPVf_USE_STRLEN)
15617         len = strlen(pv);
15618 
15619     assert(len || (flags & RCPVf_ALLOW_EMPTY));
15620 
15621     len++; /* add one for the null we will add to the end */
15622 
15623     rcpv = (RCPV *)PerlMemShared_malloc(sizeof(struct rcpv) + len);
15624     if (!rcpv)
15625         croak_no_mem();
15626 
15627     rcpv->len = len;    /* store length including null,
15628                            RCPV_LEN() subtracts 1 to account for this */
15629     rcpv->refcount = 1;
15630 
15631     if ((flags & RCPVf_NO_COPY) == 0) {
15632         (void)memcpy(rcpv->pv, pv, len-1);
15633     }
15634     rcpv->pv[len-1]= '\0'; /* the last byte should always be null */
15635     return rcpv->pv;
15636 }
15637 
15638 /*
15639 =for apidoc rcpv_free
15640 
15641 refcount decrement a shared memory refcounted string, and when
15642 the refcount goes to 0 free it using perlmemshared_free().
15643 
15644 it is the callers responsibility to ensure that the pv is the
15645 result of a rcpv_new() call.
15646 
15647 Always returns NULL so it can be used like this:
15648 
15649     thing = rcpv_free(thing);
15650 
15651 =cut
15652 */
15653 
15654 char *
Perl_rcpv_free(pTHX_ char * pv)15655 Perl_rcpv_free(pTHX_ char *pv) {
15656 
15657     PERL_ARGS_ASSERT_RCPV_FREE;
15658 
15659     PERL_UNUSED_CONTEXT;
15660 
15661     if (!pv)
15662         return NULL;
15663     RCPV *rcpv = RCPVx(pv);
15664 
15665     assert(rcpv->refcount);
15666     assert(rcpv->len);
15667 
15668     OP_REFCNT_LOCK;
15669     if (--rcpv->refcount == 0) {
15670         rcpv->len = 0;
15671         PerlMemShared_free(rcpv);
15672     }
15673     OP_REFCNT_UNLOCK;
15674     return NULL;
15675 }
15676 
15677 /*
15678 =for apidoc rcpv_copy
15679 
15680 refcount increment a shared memory refcounted string, and when
15681 the refcount goes to 0 free it using PerlMemShared_free().
15682 
15683 It is the callers responsibility to ensure that the pv is the
15684 result of a rcpv_new() call.
15685 
15686 Returns the same pointer that was passed in.
15687 
15688     new = rcpv_copy(pv);
15689 
15690 =cut
15691 */
15692 
15693 
15694 char *
Perl_rcpv_copy(pTHX_ char * pv)15695 Perl_rcpv_copy(pTHX_ char *pv) {
15696 
15697     PERL_ARGS_ASSERT_RCPV_COPY;
15698 
15699     PERL_UNUSED_CONTEXT;
15700 
15701     if (!pv)
15702         return NULL;
15703     RCPV *rcpv = RCPVx(pv);
15704     OP_REFCNT_LOCK;
15705     rcpv->refcount++;
15706     OP_REFCNT_UNLOCK;
15707     return pv;
15708 }
15709 
15710 /*
15711  * ex: set ts=8 sts=4 sw=4 et:
15712  */
15713